{-# 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
displayException :: DeviceSourceError -> String
$cdisplayException :: DeviceSourceError -> String
fromException :: SomeException -> Maybe DeviceSourceError
$cfromException :: SomeException -> Maybe DeviceSourceError
toException :: DeviceSourceError -> SomeException
$ctoException :: DeviceSourceError -> SomeException
$cp2Exception :: Show DeviceSourceError
$cp1Exception :: Typeable DeviceSourceError
Exception

instance Show DeviceSourceError where
  show :: DeviceSourceError -> String
show (IOCtlGrabError pth :: String
pth)    = "Could not perform IOCTL grab on: "    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pth
  show (IOCtlReleaseError pth :: String
pth) = "Could not perform IOCTL release on: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pth
  show (KeyIODecodeError msg :: String
msg)  = "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 :: Fd -> Bool -> m Int
ioctl_keyboard (Fd h :: CInt
h) b :: 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> CInt -> IO CInt
c_ioctl_keyboard CInt
h (if Bool
b then 1 else 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 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 bs :: 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 (a :: e
a, b :: d
b, c :: c
c, d :: b
d, e :: 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 :: (DeviceSourceCfg -> f DeviceSourceCfg)
-> DeviceFile -> f DeviceFile
deviceSourceCfg = (DeviceSourceCfg -> f DeviceSourceCfg)
-> DeviceFile -> f DeviceFile
forall c. HasDeviceFile c => Lens' c DeviceSourceCfg
cfg
instance HasKeyEventParser  DeviceFile where keyEventParser :: (KeyEventParser -> f KeyEventParser) -> DeviceFile -> f DeviceFile
keyEventParser  = (DeviceSourceCfg -> f DeviceSourceCfg)
-> DeviceFile -> f DeviceFile
forall c. HasDeviceFile c => Lens' c 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
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 :: KeyEventParser -> String -> RIO e (Acquire KeySource)
deviceSource pr :: KeyEventParser
pr pt :: 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 :: 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 :: KeyEventParser -> String -> RIO e DeviceFile
lsOpen pr :: KeyEventParser
pr pt :: String
pt = do
  Fd
h  <- IO Fd -> RIO e Fd
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fd -> RIO e Fd)
-> (OpenFileFlags -> IO Fd) -> OpenFileFlags -> RIO e Fd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd String
pt OpenMode
ReadOnly Maybe FileMode
forall a. Maybe a
Nothing (OpenFileFlags -> RIO e Fd) -> OpenFileFlags -> RIO e Fd
forall a b. (a -> b) -> a -> b
$
    Bool -> Bool -> Bool -> Bool -> Bool -> OpenFileFlags
OpenFileFlags Bool
False Bool
False Bool
False Bool
False Bool
False
  Handle
hd <- IO Handle -> RIO e Handle
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 -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "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 (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 :: DeviceFile -> RIO e ()
lsClose src :: DeviceFile
src = do
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "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
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
pth)
  IO () -> RIO e ()
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
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 :: DeviceFile -> RIO e KeyEvent
lsRead src :: 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
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
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)
prs (ByteString -> Either String LinuxKeyEvent)
-> ByteString -> Either String LinuxKeyEvent
forall a b. (a -> b) -> a -> b
$ ByteString
bts) of
    Right p :: LinuxKeyEvent
p -> case LinuxKeyEvent -> Maybe KeyEvent
fromLinuxKeyEvent LinuxKeyEvent
p of
      Just e :: KeyEvent
e  -> KeyEvent -> RIO e KeyEvent
forall (m :: * -> *) a. Monad m => a -> m a
return KeyEvent
e
      Nothing -> DeviceFile -> RIO e KeyEvent
forall e. HasLogFunc e => DeviceFile -> RIO e KeyEvent
lsRead DeviceFile
src
    Left s :: 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