{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-}
{-|
Module      : KMonad.Keyboard.IO.Linux.UinputSink
Description : Using Linux's uinput interface to emit events
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable
-}
module KMonad.Keyboard.IO.Linux.UinputSink
  ( UinputSink
  , UinputCfg(..)
  , keyboardName
  , vendorCode
  , productCode
  , productVersion
  , postInit
  , uinputSink
  , defUinputCfg
  )
where

import KMonad.Prelude

import Data.Time.Clock.System (getSystemTime)

import Foreign.C.String
import Foreign.C.Types
import System.Posix     hiding (sync)
import UnliftIO.Async   (async)
import UnliftIO.Process (spawnCommand)

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

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

type SinkId = String

-- | A collection of everything that can go wrong with the 'UinputSink'
data UinputSinkError
  = UinputRegistrationError SinkId               -- ^ Could not register device
  | UinputReleaseError      SinkId               -- ^ Could not release device
  | SinkEncodeError         SinkId LinuxKeyEvent -- ^ Could not decode event
  | EmptyNameError                               -- ^ Invalid name
  deriving Show UinputSinkError
Typeable UinputSinkError
(Typeable UinputSinkError, Show UinputSinkError) =>
(UinputSinkError -> SomeException)
-> (SomeException -> Maybe UinputSinkError)
-> (UinputSinkError -> String)
-> Exception UinputSinkError
SomeException -> Maybe UinputSinkError
UinputSinkError -> String
UinputSinkError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: UinputSinkError -> SomeException
toException :: UinputSinkError -> SomeException
$cfromException :: SomeException -> Maybe UinputSinkError
fromException :: SomeException -> Maybe UinputSinkError
$cdisplayException :: UinputSinkError -> String
displayException :: UinputSinkError -> String
Exception

instance Show UinputSinkError where
  show :: UinputSinkError -> String
show (UinputRegistrationError String
snk) = String
"Could not register sink with OS: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
snk
  show (UinputReleaseError String
snk) = String
"Could not unregister sink with OS: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
snk
  show (SinkEncodeError String
snk LinuxKeyEvent
a) = [String] -> String
unwords
    [ String
"Could not encode Keyaction"
    , LinuxKeyEvent -> String
forall a. Show a => a -> String
show LinuxKeyEvent
a
    , String
"to bytes for writing to"
    , String
snk
    ]
  show UinputSinkError
EmptyNameError = String
"Provided empty name for Uinput keyboard"

makeClassyPrisms ''UinputSinkError


--------------------------------------------------------------------------------
-- $cfg

-- | Configuration of the Uinput keyboard to instantiate
data UinputCfg = UinputCfg
  { UinputCfg -> CInt
_vendorCode     :: !CInt
  , UinputCfg -> CInt
_productCode    :: !CInt
  , UinputCfg -> CInt
_productVersion :: !CInt
  , UinputCfg -> String
_keyboardName   :: !String
  , UinputCfg -> Maybe String
_postInit       :: !(Maybe String)
  } deriving (UinputCfg -> UinputCfg -> Bool
(UinputCfg -> UinputCfg -> Bool)
-> (UinputCfg -> UinputCfg -> Bool) -> Eq UinputCfg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UinputCfg -> UinputCfg -> Bool
== :: UinputCfg -> UinputCfg -> Bool
$c/= :: UinputCfg -> UinputCfg -> Bool
/= :: UinputCfg -> UinputCfg -> Bool
Eq, Int -> UinputCfg -> ShowS
[UinputCfg] -> ShowS
UinputCfg -> String
(Int -> UinputCfg -> ShowS)
-> (UinputCfg -> String)
-> ([UinputCfg] -> ShowS)
-> Show UinputCfg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UinputCfg -> ShowS
showsPrec :: Int -> UinputCfg -> ShowS
$cshow :: UinputCfg -> String
show :: UinputCfg -> String
$cshowList :: [UinputCfg] -> ShowS
showList :: [UinputCfg] -> ShowS
Show)
makeClassy ''UinputCfg

-- | Default Uinput configuration
defUinputCfg :: UinputCfg
defUinputCfg :: UinputCfg
defUinputCfg = UinputCfg
  { _vendorCode :: CInt
_vendorCode     = CInt
0x1235
  , _productCode :: CInt
_productCode    = CInt
0x5679
  , _productVersion :: CInt
_productVersion = CInt
0x0000
  , _keyboardName :: String
_keyboardName   = String
"KMonad simulated keyboard"
  , _postInit :: Maybe String
_postInit       = Maybe String
forall a. Maybe a
Nothing
  }

-- | UinputSink is an MVar to a filehandle
data UinputSink = UinputSink
  { UinputSink -> UinputCfg
_cfg     :: UinputCfg
  , UinputSink -> MVar Fd
_st      :: MVar Fd
  }
makeLenses ''UinputSink

-- | Return a new uinput 'KeySink' with extra options
uinputSink :: HasLogFunc e => UinputCfg -> RIO e (Acquire KeySink)
uinputSink :: forall e. HasLogFunc e => UinputCfg -> RIO e (Acquire KeySink)
uinputSink UinputCfg
c = RIO e UinputSink
-> (UinputSink -> RIO e ())
-> (UinputSink -> KeyEvent -> RIO e ())
-> RIO e (Acquire KeySink)
forall e snk.
HasLogFunc e =>
RIO e snk
-> (snk -> RIO e ())
-> (snk -> KeyEvent -> RIO e ())
-> RIO e (Acquire KeySink)
mkKeySink (UinputCfg -> RIO e UinputSink
forall e. HasLogFunc e => UinputCfg -> RIO e UinputSink
usOpen UinputCfg
c) UinputSink -> RIO e ()
forall e. HasLogFunc e => UinputSink -> RIO e ()
usClose UinputSink -> KeyEvent -> RIO e ()
forall e. HasLogFunc e => UinputSink -> KeyEvent -> RIO e ()
usWrite

--------------------------------------------------------------------------------
-- FFI calls and type-friendly wrappers

foreign import ccall "acquire_uinput_keysink"
  c_acquire_uinput_keysink
    :: CInt    -- ^ Posix handle to the file to open
    -> CString -- ^ Name to give to the keyboard
    -> CInt    -- ^ Vendor ID
    -> CInt    -- ^ Product ID
    -> CInt    -- ^ Version ID
    -> IO Int

foreign import ccall "release_uinput_keysink"
  c_release_uinput_keysink :: CInt -> IO Int

foreign import ccall "send_event"
  c_send_event :: CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO Int

-- | Create and acquire a Uinput device
acquire_uinput_keysink :: MonadIO m => Fd -> UinputCfg -> m Int
acquire_uinput_keysink :: forall (m :: * -> *). MonadIO m => Fd -> UinputCfg -> m Int
acquire_uinput_keysink (Fd CInt
h) UinputCfg
c = IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
  CString
cstr <- String -> IO CString
newCString (String -> IO CString) -> String -> IO CString
forall a b. (a -> b) -> a -> b
$ UinputCfg
cUinputCfg -> Getting String UinputCfg String -> String
forall s a. s -> Getting a s a -> a
^.Getting String UinputCfg String
forall c. HasUinputCfg c => Lens' c String
Lens' UinputCfg String
keyboardName
  CInt -> CString -> CInt -> CInt -> CInt -> IO Int
c_acquire_uinput_keysink CInt
h CString
cstr
    (UinputCfg
cUinputCfg -> Getting CInt UinputCfg CInt -> CInt
forall s a. s -> Getting a s a -> a
^.Getting CInt UinputCfg CInt
forall c. HasUinputCfg c => Lens' c CInt
Lens' UinputCfg CInt
vendorCode) (UinputCfg
cUinputCfg -> Getting CInt UinputCfg CInt -> CInt
forall s a. s -> Getting a s a -> a
^.Getting CInt UinputCfg CInt
forall c. HasUinputCfg c => Lens' c CInt
Lens' UinputCfg CInt
productCode) (UinputCfg
cUinputCfg -> Getting CInt UinputCfg CInt -> CInt
forall s a. s -> Getting a s a -> a
^.Getting CInt UinputCfg CInt
forall c. HasUinputCfg c => Lens' c CInt
Lens' UinputCfg CInt
productVersion)

-- | Release a Uinput device
release_uinput_keysink :: MonadIO m => Fd -> m Int
release_uinput_keysink :: forall (m :: * -> *). MonadIO m => Fd -> m Int
release_uinput_keysink (Fd CInt
h) = IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ CInt -> IO Int
c_release_uinput_keysink CInt
h

-- | Using a Uinput device, send a LinuxKeyEvent to the Linux kernel
send_event :: ()
  => UinputSink
  -> Fd
  -> LinuxKeyEvent
  -> RIO e ()
send_event :: forall e. UinputSink -> Fd -> LinuxKeyEvent -> RIO e ()
send_event UinputSink
u (Fd CInt
h) e :: LinuxKeyEvent
e@(LinuxKeyEvent (CInt
s', CInt
ns', CInt
typ, CInt
c, CInt
val)) = do
  IO Int -> RIO e Int
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO Int
c_send_event CInt
h CInt
typ CInt
c CInt
val CInt
s' CInt
ns')
    RIO e Int -> UinputSinkError -> RIO e ()
forall (m :: * -> *) e.
(MonadUnliftIO m, Exception e) =>
m Int -> e -> m ()
`onErr` String -> LinuxKeyEvent -> UinputSinkError
SinkEncodeError (UinputSink
uUinputSink -> Getting String UinputSink String -> String
forall s a. s -> Getting a s a -> a
^.(UinputCfg -> Const String UinputCfg)
-> UinputSink -> Const String UinputSink
Lens' UinputSink UinputCfg
cfg((UinputCfg -> Const String UinputCfg)
 -> UinputSink -> Const String UinputSink)
-> Getting String UinputCfg String
-> Getting String UinputSink String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting String UinputCfg String
forall c. HasUinputCfg c => Lens' c String
Lens' UinputCfg String
keyboardName) LinuxKeyEvent
e


--------------------------------------------------------------------------------

-- | Create a new UinputSink
usOpen :: HasLogFunc e => UinputCfg -> RIO e UinputSink
usOpen :: forall e. HasLogFunc e => UinputCfg -> RIO e UinputSink
usOpen UinputCfg
c = do
  Bool -> RIO e () -> RIO e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ UinputCfg
c UinputCfg -> Getting String UinputCfg String -> String
forall s a. s -> Getting a s a -> a
^. Getting String UinputCfg String
forall c. HasUinputCfg c => Lens' c String
Lens' UinputCfg String
keyboardName) (RIO e () -> RIO e ()) -> RIO e () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ UinputSinkError -> RIO e ()
forall e a. (HasCallStack, Exception e) => e -> RIO e a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM UinputSinkError
EmptyNameError
  Fd
fd <- 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
"/dev/uinput"
    OpenMode
WriteOnly
#if !MIN_VERSION_unix(2,8,0)
    Nothing
#endif
    OpenFileFlags
defaultFileFlags
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Registering Uinput device"
  Fd -> UinputCfg -> RIO e Int
forall (m :: * -> *). MonadIO m => Fd -> UinputCfg -> m Int
acquire_uinput_keysink Fd
fd UinputCfg
c RIO e Int -> UinputSinkError -> RIO e ()
forall (m :: * -> *) e.
(MonadUnliftIO m, Exception e) =>
m Int -> e -> m ()
`onErr` String -> UinputSinkError
UinputRegistrationError (UinputCfg
c UinputCfg -> Getting String UinputCfg String -> String
forall s a. s -> Getting a s a -> a
^. Getting String UinputCfg String
forall c. HasUinputCfg c => Lens' c String
Lens' UinputCfg String
keyboardName)
  ((String -> RIO e ()) -> Maybe String -> RIO e ())
-> Maybe String -> (String -> RIO e ()) -> RIO e ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RIO e () -> (String -> RIO e ()) -> Maybe String -> RIO e ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RIO e () -> (String -> RIO e ()) -> Maybe String -> RIO e ())
-> RIO e () -> (String -> RIO e ()) -> Maybe String -> RIO e ()
forall a b. (a -> b) -> a -> b
$ () -> RIO e ()
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (UinputCfg
cUinputCfg
-> Getting (Maybe String) UinputCfg (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^.Getting (Maybe String) UinputCfg (Maybe String)
forall c. HasUinputCfg c => Lens' c (Maybe String)
Lens' UinputCfg (Maybe String)
postInit) ((String -> RIO e ()) -> RIO e ())
-> (String -> RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \String
cmd -> 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
$ Utf8Builder
"Running UinputSink command: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow String
cmd
    RIO e (Async ProcessHandle) -> RIO e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO e (Async ProcessHandle) -> RIO e ())
-> (String -> RIO e (Async ProcessHandle)) -> String -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RIO e ProcessHandle -> RIO e (Async ProcessHandle)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (RIO e ProcessHandle -> RIO e (Async ProcessHandle))
-> (String -> RIO e ProcessHandle)
-> String
-> RIO e (Async ProcessHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RIO e ProcessHandle
forall (m :: * -> *). MonadIO m => String -> m ProcessHandle
spawnCommand (String -> RIO e ()) -> String -> RIO e ()
forall a b. (a -> b) -> a -> b
$ String
cmd
  UinputCfg -> MVar Fd -> UinputSink
UinputSink UinputCfg
c (MVar Fd -> UinputSink) -> RIO e (MVar Fd) -> RIO e UinputSink
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> RIO e (MVar Fd)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Fd
fd

-- | Close a 'UinputSink'
usClose :: HasLogFunc e => UinputSink -> RIO e ()
usClose :: forall e. HasLogFunc e => UinputSink -> RIO e ()
usClose UinputSink
snk = MVar Fd -> (Fd -> RIO e ()) -> RIO e ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar (UinputSink
snkUinputSink -> Getting (MVar Fd) UinputSink (MVar Fd) -> MVar Fd
forall s a. s -> Getting a s a -> a
^.Getting (MVar Fd) UinputSink (MVar Fd)
Lens' UinputSink (MVar Fd)
st) ((Fd -> RIO e ()) -> RIO e ()) -> (Fd -> RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \Fd
h -> RIO e () -> RIO e () -> RIO e ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (Fd -> RIO e ()
release Fd
h) (Fd -> RIO e ()
forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Fd -> m ()
close Fd
h)
  where
    release :: Fd -> RIO e ()
release Fd
h = do
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Unregistering Uinput device"
      Fd -> RIO e Int
forall (m :: * -> *). MonadIO m => Fd -> m Int
release_uinput_keysink Fd
h
        RIO e Int -> UinputSinkError -> RIO e ()
forall (m :: * -> *) e.
(MonadUnliftIO m, Exception e) =>
m Int -> e -> m ()
`onErr` String -> UinputSinkError
UinputReleaseError (UinputSink
snkUinputSink -> Getting String UinputSink String -> String
forall s a. s -> Getting a s a -> a
^.(UinputCfg -> Const String UinputCfg)
-> UinputSink -> Const String UinputSink
Lens' UinputSink UinputCfg
cfg((UinputCfg -> Const String UinputCfg)
 -> UinputSink -> Const String UinputSink)
-> Getting String UinputCfg String
-> Getting String UinputSink String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting String UinputCfg String
forall c. HasUinputCfg c => Lens' c String
Lens' UinputCfg String
keyboardName)

    close :: Fd -> m ()
close Fd
h = do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Closing Uinput device file"
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
h

-- | Write a keyboard event to the sink and sync the driver state. Using an MVar
-- ensures that we can never have 2 threads try to write at the same time.
usWrite :: HasLogFunc e => UinputSink -> KeyEvent -> RIO e ()
usWrite :: forall e. HasLogFunc e => UinputSink -> KeyEvent -> RIO e ()
usWrite UinputSink
u KeyEvent
e = MVar Fd -> (Fd -> RIO e ()) -> RIO e ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar (UinputSink
uUinputSink -> Getting (MVar Fd) UinputSink (MVar Fd) -> MVar Fd
forall s a. s -> Getting a s a -> a
^.Getting (MVar Fd) UinputSink (MVar Fd)
Lens' UinputSink (MVar Fd)
st) ((Fd -> RIO e ()) -> RIO e ()) -> (Fd -> RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \Fd
fd -> do
  SystemTime
now <- IO SystemTime -> RIO e SystemTime
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
  UinputSink -> Fd -> LinuxKeyEvent -> RIO e ()
forall e. UinputSink -> Fd -> LinuxKeyEvent -> RIO e ()
send_event UinputSink
u Fd
fd (LinuxKeyEvent -> RIO e ())
-> (SystemTime -> LinuxKeyEvent) -> SystemTime -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyEvent -> SystemTime -> LinuxKeyEvent
toLinuxKeyEvent KeyEvent
e (SystemTime -> RIO e ()) -> SystemTime -> RIO e ()
forall a b. (a -> b) -> a -> b
$ SystemTime
now
  UinputSink -> Fd -> LinuxKeyEvent -> RIO e ()
forall e. UinputSink -> Fd -> LinuxKeyEvent -> RIO e ()
send_event UinputSink
u Fd
fd (LinuxKeyEvent -> RIO e ())
-> (SystemTime -> LinuxKeyEvent) -> SystemTime -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemTime -> LinuxKeyEvent
sync              (SystemTime -> RIO e ()) -> SystemTime -> RIO e ()
forall a b. (a -> b) -> a -> b
$ SystemTime
now