module Evdev.Stream where

import Control.Concurrent
import Control.Exception.Extra
import Control.Monad
import Control.Monad.IO.Class
import Data.Either.Combinators

import GHC.IO.Exception (IOErrorType(PermissionDenied),ioe_type)
import RawFilePath.Directory (doesFileExist,listDirectory)
import System.INotify (addWatch,initINotify)
import qualified System.INotify as I
import System.Posix.ByteString (RawFilePath)
import System.Posix.FilePath ((</>),combine)

import Streamly
import qualified Streamly.Prelude as S

import Evdev

allEvents :: IsStream t => t IO (Device, Event)
allEvents :: t IO (Device, Event)
allEvents = (Device -> Bool) -> t IO (Device, Event)
forall (t :: (* -> *) -> * -> *).
IsStream t =>
(Device -> Bool) -> t IO (Device, Event)
filteredEvents ((Device -> Bool) -> t IO (Device, Event))
-> (Device -> Bool) -> t IO (Device, Event)
forall a b. (a -> b) -> a -> b
$ Bool -> Device -> Bool
forall a b. a -> b -> a
const Bool
True

filteredEvents :: IsStream t => (Device -> Bool) -> t IO (Device, Event)
filteredEvents :: (Device -> Bool) -> t IO (Device, Event)
filteredEvents p :: Device -> Bool
p = AsyncT IO Device -> t IO (Device, Event)
forall (t :: (* -> *) -> * -> *).
IsStream t =>
AsyncT IO Device -> t IO (Device, Event)
readEventsMany (AsyncT IO Device -> t IO (Device, Event))
-> AsyncT IO Device -> t IO (Device, Event)
forall a b. (a -> b) -> a -> b
$ (Device -> Bool) -> AsyncT IO Device -> AsyncT IO Device
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> Bool) -> t m a -> t m a
S.filter Device -> Bool
p (AsyncT IO Device -> AsyncT IO Device)
-> AsyncT IO Device -> AsyncT IO Device
forall a b. (a -> b) -> a -> b
$ AsyncT IO RawFilePath -> AsyncT IO Device
forall (t :: (* -> *) -> * -> *).
(Functor (t IO), IsStream t) =>
t IO RawFilePath -> t IO Device
makeDevices (AsyncT IO RawFilePath -> AsyncT IO Device)
-> AsyncT IO RawFilePath -> AsyncT IO Device
forall a b. (a -> b) -> a -> b
$ AsyncT IO RawFilePath
forall (t :: (* -> *) -> * -> *).
(IsStream t, MonadIO (t IO)) =>
t IO RawFilePath
existingDevicePaths AsyncT IO RawFilePath
-> AsyncT IO RawFilePath -> AsyncT IO RawFilePath
forall a. Semigroup a => a -> a -> a
<> AsyncT IO RawFilePath
forall (t :: (* -> *) -> * -> *).
(MonadIO (t IO), IsStream t) =>
t IO RawFilePath
newDevicePaths

-- reads until encountering an IOException
readEvents :: IsStream t => Device -> t IO Event
readEvents :: Device -> t IO Event
readEvents dev :: Device
dev = SerialT IO Event -> t IO Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
SerialT m a -> t m a
serially (SerialT IO Event -> t IO Event) -> SerialT IO Event -> t IO Event
forall a b. (a -> b) -> a -> b
$ IO (Maybe Event) -> SerialT IO Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m (Maybe a) -> t m a
unfoldrM' (IO (Maybe Event) -> SerialT IO Event)
-> IO (Maybe Event) -> SerialT IO Event
forall a b. (a -> b) -> a -> b
$ (Either IOException Event -> Maybe Event)
-> IO (Either IOException Event) -> IO (Maybe Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOException Event -> Maybe Event
forall a b. Either a b -> Maybe b
rightToMaybe (IO (Either IOException Event) -> IO (Maybe Event))
-> IO (Either IOException Event) -> IO (Maybe Event)
forall a b. (a -> b) -> a -> b
$ IO Event -> IO (Either IOException Event)
forall a. IO a -> IO (Either IOException a)
tryIO (IO Event -> IO (Either IOException Event))
-> IO Event -> IO (Either IOException Event)
forall a b. (a -> b) -> a -> b
$ Device -> Set ReadFlags -> IO Event
nextEvent Device
dev Set ReadFlags
defaultReadFlags

readEventsMany :: IsStream t => AsyncT IO Device -> t IO (Device, Event)
readEventsMany :: AsyncT IO Device -> t IO (Device, Event)
readEventsMany = 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 -> AsyncT IO (Device, Event))
-> AsyncT IO Device
-> t IO (Device, Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsyncT IO (AsyncT IO (Device, Event)) -> AsyncT IO (Device, Event)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (AsyncT IO (AsyncT IO (Device, Event))
 -> AsyncT IO (Device, Event))
-> (AsyncT IO Device -> AsyncT IO (AsyncT IO (Device, Event)))
-> AsyncT IO Device
-> AsyncT IO (Device, Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Device -> AsyncT IO (Device, Event))
-> AsyncT IO Device -> AsyncT IO (AsyncT IO (Device, Event))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> b) -> t m a -> t m b
S.map ((Device -> AsyncT IO (Device, Event))
 -> AsyncT IO Device -> AsyncT IO (AsyncT IO (Device, Event)))
-> (Device -> AsyncT IO (Device, Event))
-> AsyncT IO Device
-> AsyncT IO (AsyncT IO (Device, Event))
forall a b. (a -> b) -> a -> b
$ \d :: Device
d -> ((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
$ Device -> AsyncT IO Event
forall (t :: (* -> *) -> * -> *).
IsStream t =>
Device -> t IO Event
readEvents Device
d))

makeDevices :: (Functor (t IO), IsStream t) => t IO RawFilePath -> t IO Device
makeDevices :: t IO RawFilePath -> t IO Device
makeDevices = (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 RawFilePath -> IO (Maybe Device)
maybeNewDevice

existingDevicePaths :: (IsStream t, MonadIO (t IO)) => t IO RawFilePath
existingDevicePaths :: t IO RawFilePath
existingDevicePaths = [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]
lsFiles RawFilePath
evdevDir)

newDevicePaths :: (MonadIO (t IO), IsStream t) => t IO RawFilePath
newDevicePaths :: t IO RawFilePath
newDevicePaths =
    let watcher :: MVar RawFilePath -> Event -> IO ()
watcher mvar :: MVar RawFilePath
mvar = \case
            I.Created False path :: RawFilePath
path -> do -- file (not directory) created
                let fullPath :: RawFilePath
fullPath = RawFilePath
evdevDir RawFilePath -> RawFilePath -> RawFilePath
</> RawFilePath
path
                (IOException -> Bool) -> Int -> IO () -> IO ()
forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
handleBoolRetry ((IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
PermissionDenied) (IOErrorType -> Bool)
-> (IOException -> IOErrorType) -> IOException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> IOErrorType
ioe_type) 100 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar RawFilePath -> RawFilePath -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar RawFilePath
mvar RawFilePath
fullPath
            _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    in do
        MVar RawFilePath
mvar <- IO (MVar RawFilePath) -> t IO (MVar RawFilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar RawFilePath)
forall a. IO (MVar a)
newEmptyMVar
        INotify
iNot <- IO INotify -> t IO INotify
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO INotify
initINotify
        WatchDescriptor
_ <- IO WatchDescriptor -> t IO WatchDescriptor
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WatchDescriptor -> t IO WatchDescriptor)
-> IO WatchDescriptor -> t IO WatchDescriptor
forall a b. (a -> b) -> a -> b
$ INotify
-> [EventVariety]
-> RawFilePath
-> (Event -> IO ())
-> IO WatchDescriptor
addWatch INotify
iNot [Item [EventVariety]
EventVariety
I.Create] RawFilePath
evdevDir (MVar RawFilePath -> Event -> IO ()
watcher MVar RawFilePath
mvar)
        SerialT IO RawFilePath -> t IO RawFilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
SerialT m a -> t m a
serially (SerialT IO RawFilePath -> t IO RawFilePath)
-> SerialT IO RawFilePath -> t IO RawFilePath
forall a b. (a -> b) -> a -> b
$ IO RawFilePath -> SerialT IO RawFilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m a -> t m a
S.repeatM (IO RawFilePath -> SerialT IO RawFilePath)
-> IO RawFilePath -> SerialT IO RawFilePath
forall a b. (a -> b) -> a -> b
$ MVar RawFilePath -> IO RawFilePath
forall a. MVar a -> IO a
takeMVar MVar RawFilePath
mvar


-- retry the action after encountering an exception satisfying p
handleBoolRetry :: Exception e => (e -> Bool) -> Int -> IO a -> IO a
handleBoolRetry :: (e -> Bool) -> Int -> IO a -> IO a
handleBoolRetry p :: e -> Bool
p t :: Int
t x :: IO a
x = (e -> Bool) -> (e -> IO a) -> IO a -> IO a
forall e a.
Exception e =>
(e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool e -> Bool
p (IO a -> e -> IO a
forall a b. a -> b -> a
const (IO a -> e -> IO a) -> IO a -> e -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
t IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (e -> Bool) -> Int -> IO a -> IO a
forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
handleBoolRetry e -> Bool
p Int
t IO a
x) IO a
x


{- Util -}

-- a specialization of S.unfoldrM which doesn't make use of any value from the previous round
unfoldrM' :: (IsStream t, MonadAsync m) => m (Maybe a) -> t m a
unfoldrM' :: m (Maybe a) -> t m a
unfoldrM' x :: 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

-- lists files only, and returns full paths.
lsFiles :: RawFilePath -> IO [RawFilePath]
lsFiles :: RawFilePath -> IO [RawFilePath]
lsFiles = (RawFilePath -> IO Bool) -> [RawFilePath] -> IO [RawFilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM RawFilePath -> IO Bool
doesFileExist ([RawFilePath] -> IO [RawFilePath])
-> (RawFilePath -> IO [RawFilePath])
-> RawFilePath
-> IO [RawFilePath]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((([RawFilePath] -> [RawFilePath])
-> IO [RawFilePath] -> IO [RawFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([RawFilePath] -> [RawFilePath])
 -> IO [RawFilePath] -> IO [RawFilePath])
-> (RawFilePath -> [RawFilePath] -> [RawFilePath])
-> RawFilePath
-> IO [RawFilePath]
-> IO [RawFilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawFilePath -> RawFilePath) -> [RawFilePath] -> [RawFilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((RawFilePath -> RawFilePath) -> [RawFilePath] -> [RawFilePath])
-> (RawFilePath -> RawFilePath -> RawFilePath)
-> RawFilePath
-> [RawFilePath]
-> [RawFilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> RawFilePath -> RawFilePath
combine) (RawFilePath -> IO [RawFilePath] -> IO [RawFilePath])
-> (RawFilePath -> IO [RawFilePath])
-> RawFilePath
-> IO [RawFilePath]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RawFilePath -> IO [RawFilePath]
listDirectory)