{-# LANGUAGE CPP            #-}
{-# LANGUAGE DeriveAnyClass #-}
{-|
Module      : KMonad.Keyboard.IO.Linux.DeviceSource
Description : Load and acquire a linux /dev/input device
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

-}
module KMonad.Keyboard.IO.Linux.DeviceSource
  ( deviceSource
  , deviceSource64

  , KeyEventParser
  , decode64
  )
where

import KMonad.Prelude
import Foreign.C.Types
import System.Posix

import KMonad.Keyboard.IO.Linux.Types
import KMonad.Util

import qualified Data.Serialize as B (decode)
import qualified RIO.ByteString as B

--------------------------------------------------------------------------------
-- $err

data DeviceSourceError
  = IOCtlGrabError    FilePath
  | IOCtlReleaseError FilePath
  | KeyIODecodeError  String
  deriving Show DeviceSourceError
Typeable DeviceSourceError
(Typeable DeviceSourceError, Show DeviceSourceError) =>
(DeviceSourceError -> SomeException)
-> (SomeException -> Maybe DeviceSourceError)
-> (DeviceSourceError -> String)
-> Exception DeviceSourceError
SomeException -> Maybe DeviceSourceError
DeviceSourceError -> String
DeviceSourceError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: DeviceSourceError -> SomeException
toException :: DeviceSourceError -> SomeException
$cfromException :: SomeException -> Maybe DeviceSourceError
fromException :: SomeException -> Maybe DeviceSourceError
$cdisplayException :: DeviceSourceError -> String
displayException :: DeviceSourceError -> String
Exception

instance Show DeviceSourceError where
  show :: DeviceSourceError -> String
show (IOCtlGrabError String
pth)    = String
"Could not perform IOCTL grab on: "    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pth
  show (IOCtlReleaseError String
pth) = String
"Could not perform IOCTL release on: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pth
  show (KeyIODecodeError String
msg)  = String
"KeyEvent decode failed with msg: "    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg

makeClassyPrisms ''DeviceSourceError

--------------------------------------------------------------------------------
-- $ffi
foreign import ccall "ioctl_keyboard"
  c_ioctl_keyboard :: CInt -> CInt -> IO CInt

-- | Perform an IOCTL operation on an open keyboard handle
ioctl_keyboard :: MonadIO m
  => Fd      -- ^ Descriptor to open keyboard file (like /dev/input/eventXX)
  -> Bool    -- ^ True to grab, False to ungrab
  -> m Int   -- ^ Return the exit code
ioctl_keyboard :: forall (m :: * -> *). MonadIO m => Fd -> Bool -> m Int
ioctl_keyboard (Fd CInt
h) Bool
b = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> m CInt -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  IO CInt -> m CInt
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> CInt -> IO CInt
c_ioctl_keyboard CInt
h (if Bool
b then CInt
1 else CInt
0))


--------------------------------------------------------------------------------
-- $decoding

-- | A 'KeyEventParser' describes how to read and parse 'LinuxKeyEvent's from
-- the binary data-stream provided by the device-file.
data KeyEventParser = KeyEventParser
  { KeyEventParser -> Int
_nbytes :: !Int
    -- ^ Size of 1 input event in bytes
  , KeyEventParser -> ByteString -> Either String LinuxKeyEvent
_prs    :: !(B.ByteString -> Either String LinuxKeyEvent)
    -- ^ Function to convert bytestring to event
  }
makeClassy ''KeyEventParser

-- | Default configuration for parsing keyboard events
defEventParser :: KeyEventParser
defEventParser :: KeyEventParser
defEventParser = Int
-> (ByteString -> Either String LinuxKeyEvent) -> KeyEventParser
KeyEventParser Int
24 ByteString -> Either String LinuxKeyEvent
decode64

-- | The KeyEventParser that works on my 64-bit Linux environment
decode64 :: B.ByteString -> Either String LinuxKeyEvent
decode64 :: ByteString -> Either String LinuxKeyEvent
decode64 ByteString
bs = (Word64, Word64, Word16, Word16, Int32) -> LinuxKeyEvent
forall a b c d e.
(Integral a, Integral b, Integral c, Integral d, Integral e) =>
(a, b, c, d, e) -> LinuxKeyEvent
linuxKeyEvent ((Word64, Word64, Word16, Word16, Int32) -> LinuxKeyEvent)
-> ((Int32, Word16, Word16, Word64, Word64)
    -> (Word64, Word64, Word16, Word16, Int32))
-> (Int32, Word16, Word16, Word64, Word64)
-> LinuxKeyEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32, Word16, Word16, Word64, Word64)
-> (Word64, Word64, Word16, Word16, Int32)
forall {e} {d} {c} {b} {a}. (e, d, c, b, a) -> (a, b, c, d, e)
fliptup ((Int32, Word16, Word16, Word64, Word64) -> LinuxKeyEvent)
-> Either String (Int32, Word16, Word16, Word64, Word64)
-> Either String LinuxKeyEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String (Int32, Word16, Word16, Word64, Word64)
result
  where
    result :: Either String (Int32, Word16, Word16, Word64, Word64)
    result :: Either String (Int32, Word16, Word16, Word64, Word64)
result = ByteString -> Either String (Int32, Word16, Word16, Word64, Word64)
forall a. Serialize a => ByteString -> Either String a
B.decode (ByteString
 -> Either String (Int32, Word16, Word16, Word64, Word64))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (Int32, Word16, Word16, Word64, Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.reverse (ByteString
 -> Either String (Int32, Word16, Word16, Word64, Word64))
-> ByteString
-> Either String (Int32, Word16, Word16, Word64, Word64)
forall a b. (a -> b) -> a -> b
$ ByteString
bs

    fliptup :: (e, d, c, b, a) -> (a, b, c, d, e)
fliptup (e
a, d
b, c
c, b
d, a
e) = (a
e, b
d, c
c, d
b, e
a)


--------------------------------------------------------------------------------
-- $types

-- | Configurable components of a DeviceSource
data DeviceSourceCfg = DeviceSourceCfg
  { DeviceSourceCfg -> String
_pth     :: !FilePath        -- ^ Path to the event-file
  , DeviceSourceCfg -> KeyEventParser
_parser  :: !KeyEventParser  -- ^ The method used to decode events
  }
makeClassy ''DeviceSourceCfg

-- | Collection of data used to read from linux input.h event stream
data DeviceFile = DeviceFile
  { DeviceFile -> DeviceSourceCfg
_cfg :: !DeviceSourceCfg -- ^ Configuration settings
  , DeviceFile -> Fd
_fd  :: !Fd              -- ^ Posix filedescriptor to the device file
  , DeviceFile -> Handle
_hdl :: !Handle          -- ^ Haskell handle to the device file
  }
makeClassy ''DeviceFile

instance HasDeviceSourceCfg DeviceFile where deviceSourceCfg :: Lens' DeviceFile DeviceSourceCfg
deviceSourceCfg = (DeviceSourceCfg -> f DeviceSourceCfg)
-> DeviceFile -> f DeviceFile
forall c. HasDeviceFile c => Lens' c DeviceSourceCfg
Lens' DeviceFile DeviceSourceCfg
cfg
instance HasKeyEventParser  DeviceFile where keyEventParser :: Lens' DeviceFile KeyEventParser
keyEventParser  = (DeviceSourceCfg -> f DeviceSourceCfg)
-> DeviceFile -> f DeviceFile
forall c. HasDeviceFile c => Lens' c DeviceSourceCfg
Lens' DeviceFile DeviceSourceCfg
cfg((DeviceSourceCfg -> f DeviceSourceCfg)
 -> DeviceFile -> f DeviceFile)
-> ((KeyEventParser -> f KeyEventParser)
    -> DeviceSourceCfg -> f DeviceSourceCfg)
-> (KeyEventParser -> f KeyEventParser)
-> DeviceFile
-> f DeviceFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(KeyEventParser -> f KeyEventParser)
-> DeviceSourceCfg -> f DeviceSourceCfg
forall c. HasDeviceSourceCfg c => Lens' c KeyEventParser
Lens' DeviceSourceCfg KeyEventParser
parser

-- | Open a device file
deviceSource :: HasLogFunc e
  => KeyEventParser -- ^ The method by which to read and decode events
  -> FilePath    -- ^ The filepath to the device file
  -> RIO e (Acquire KeySource)
deviceSource :: forall e.
HasLogFunc e =>
KeyEventParser -> String -> RIO e (Acquire KeySource)
deviceSource KeyEventParser
pr String
pt = RIO e DeviceFile
-> (DeviceFile -> RIO e ())
-> (DeviceFile -> RIO e KeyEvent)
-> RIO e (Acquire KeySource)
forall e src.
HasLogFunc e =>
RIO e src
-> (src -> RIO e ())
-> (src -> RIO e KeyEvent)
-> RIO e (Acquire KeySource)
mkKeySource (KeyEventParser -> String -> RIO e DeviceFile
forall e.
HasLogFunc e =>
KeyEventParser -> String -> RIO e DeviceFile
lsOpen KeyEventParser
pr String
pt) DeviceFile -> RIO e ()
forall e. HasLogFunc e => DeviceFile -> RIO e ()
lsClose DeviceFile -> RIO e KeyEvent
forall e. HasLogFunc e => DeviceFile -> RIO e KeyEvent
lsRead

-- | Open a device file on a standard linux 64 bit architecture
deviceSource64 :: HasLogFunc e
  => FilePath  -- ^ The filepath to the device file
  -> RIO e (Acquire KeySource)
deviceSource64 :: forall e. HasLogFunc e => String -> RIO e (Acquire KeySource)
deviceSource64 = KeyEventParser -> String -> RIO e (Acquire KeySource)
forall e.
HasLogFunc e =>
KeyEventParser -> String -> RIO e (Acquire KeySource)
deviceSource KeyEventParser
defEventParser


--------------------------------------------------------------------------------
-- $io

-- | Open the keyboard, perform an ioctl grab and return a 'DeviceFile'. This
-- can throw an 'IOException' if the file cannot be opened for reading, or an
-- 'IOCtlGrabError' if an ioctl grab could not be properly performed.
lsOpen :: (HasLogFunc e)
  => KeyEventParser   -- ^ The method by which to decode events
  -> FilePath      -- ^ The path to the device file
  -> RIO e DeviceFile
lsOpen :: forall e.
HasLogFunc e =>
KeyEventParser -> String -> RIO e DeviceFile
lsOpen KeyEventParser
pr String
pt = do
  Fd
h  <- IO Fd -> RIO e Fd
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fd -> RIO e Fd) -> IO Fd -> RIO e Fd
forall a b. (a -> b) -> a -> b
$ String -> OpenMode -> OpenFileFlags -> IO Fd
openFd String
pt
    OpenMode
ReadOnly
#if !MIN_VERSION_unix(2,8,0)
    Nothing
#endif
    OpenFileFlags
defaultFileFlags
  Handle
hd <- IO Handle -> RIO e Handle
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> RIO e Handle) -> IO Handle -> RIO e Handle
forall a b. (a -> b) -> a -> b
$ Fd -> IO Handle
fdToHandle Fd
h
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Initiating ioctl grab"
  Fd -> Bool -> RIO e Int
forall (m :: * -> *). MonadIO m => Fd -> Bool -> m Int
ioctl_keyboard Fd
h Bool
True RIO e Int -> DeviceSourceError -> RIO e ()
forall (m :: * -> *) e.
(MonadUnliftIO m, Exception e) =>
m Int -> e -> m ()
`onErr` String -> DeviceSourceError
IOCtlGrabError String
pt
  DeviceFile -> RIO e DeviceFile
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (DeviceFile -> RIO e DeviceFile) -> DeviceFile -> RIO e DeviceFile
forall a b. (a -> b) -> a -> b
$ DeviceSourceCfg -> Fd -> Handle -> DeviceFile
DeviceFile (String -> KeyEventParser -> DeviceSourceCfg
DeviceSourceCfg String
pt KeyEventParser
pr) Fd
h Handle
hd

-- | Release the ioctl grab and close the device file. This can throw an
-- 'IOException' if the handle to the device cannot be properly closed, or an
-- 'IOCtlReleaseError' if the ioctl release could not be properly performed.
lsClose :: (HasLogFunc e) => DeviceFile -> RIO e ()
lsClose :: forall e. HasLogFunc e => DeviceFile -> RIO e ()
lsClose DeviceFile
src = do
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Releasing ioctl grab"
  Fd -> Bool -> RIO e Int
forall (m :: * -> *). MonadIO m => Fd -> Bool -> m Int
ioctl_keyboard (DeviceFile
srcDeviceFile -> Getting Fd DeviceFile Fd -> Fd
forall s a. s -> Getting a s a -> a
^.Getting Fd DeviceFile Fd
forall c. HasDeviceFile c => Lens' c Fd
Lens' DeviceFile Fd
fd) Bool
False RIO e Int -> DeviceSourceError -> RIO e ()
forall (m :: * -> *) e.
(MonadUnliftIO m, Exception e) =>
m Int -> e -> m ()
`onErr` String -> DeviceSourceError
IOCtlReleaseError (DeviceFile
srcDeviceFile -> Getting String DeviceFile String -> String
forall s a. s -> Getting a s a -> a
^.Getting String DeviceFile String
forall c. HasDeviceSourceCfg c => Lens' c String
Lens' DeviceFile String
pth)
  IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> (Fd -> IO ()) -> Fd -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> IO ()
closeFd (Fd -> RIO e ()) -> Fd -> RIO e ()
forall a b. (a -> b) -> a -> b
$ DeviceFile
srcDeviceFile -> Getting Fd DeviceFile Fd -> Fd
forall s a. s -> Getting a s a -> a
^.Getting Fd DeviceFile Fd
forall c. HasDeviceFile c => Lens' c Fd
Lens' DeviceFile Fd
fd

-- | Read a bytestring from an open filehandle and return a parsed event. This
-- can throw a 'KeyIODecodeError' if reading from the 'DeviceFile' fails to
-- yield a parseable sequence of bytes.
lsRead :: (HasLogFunc e) => DeviceFile -> RIO e KeyEvent
lsRead :: forall e. HasLogFunc e => DeviceFile -> RIO e KeyEvent
lsRead DeviceFile
src = do
  ByteString
bts <- Handle -> Int -> RIO e ByteString
forall (m :: * -> *). MonadIO m => Handle -> Int -> m ByteString
B.hGet (DeviceFile
srcDeviceFile -> Getting Handle DeviceFile Handle -> Handle
forall s a. s -> Getting a s a -> a
^.Getting Handle DeviceFile Handle
forall c. HasDeviceFile c => Lens' c Handle
Lens' DeviceFile Handle
hdl) (DeviceFile
srcDeviceFile -> Getting Int DeviceFile Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int DeviceFile Int
forall c. HasKeyEventParser c => Lens' c Int
Lens' DeviceFile Int
nbytes)
  case DeviceFile
srcDeviceFile
-> Getting
     (ByteString -> Either String LinuxKeyEvent)
     DeviceFile
     (ByteString -> Either String LinuxKeyEvent)
-> ByteString
-> Either String LinuxKeyEvent
forall s a. s -> Getting a s a -> a
^.Getting
  (ByteString -> Either String LinuxKeyEvent)
  DeviceFile
  (ByteString -> Either String LinuxKeyEvent)
forall c.
HasKeyEventParser c =>
Lens' c (ByteString -> Either String LinuxKeyEvent)
Lens' DeviceFile (ByteString -> Either String LinuxKeyEvent)
prs (ByteString -> Either String LinuxKeyEvent)
-> ByteString -> Either String LinuxKeyEvent
forall a b. (a -> b) -> a -> b
$ ByteString
bts of
    Right LinuxKeyEvent
p -> case LinuxKeyEvent -> Maybe KeyEvent
fromLinuxKeyEvent LinuxKeyEvent
p of
      Just KeyEvent
e  -> KeyEvent -> RIO e KeyEvent
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return KeyEvent
e
      Maybe KeyEvent
Nothing -> DeviceFile -> RIO e KeyEvent
forall e. HasLogFunc e => DeviceFile -> RIO e KeyEvent
lsRead DeviceFile
src
    Left String
s -> DeviceSourceError -> RIO e KeyEvent
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DeviceSourceError -> RIO e KeyEvent)
-> DeviceSourceError -> RIO e KeyEvent
forall a b. (a -> b) -> a -> b
$ String -> DeviceSourceError
KeyIODecodeError String
s