{-# LANGUAGE DeriveAnyClass #-}
{-|
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
import UnliftIO.Async   (async)
import UnliftIO.Process (callCommand)

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

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

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
/= :: UinputCfg -> UinputCfg -> Bool
$c/= :: UinputCfg -> UinputCfg -> Bool
== :: UinputCfg -> UinputCfg -> Bool
$c== :: 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
showList :: [UinputCfg] -> ShowS
$cshowList :: [UinputCfg] -> ShowS
show :: UinputCfg -> String
$cshow :: UinputCfg -> String
showsPrec :: Int -> UinputCfg -> ShowS
$cshowsPrec :: Int -> UinputCfg -> ShowS
Show)
makeClassy ''UinputCfg

-- | Default Uinput configuration
defUinputCfg :: UinputCfg
defUinputCfg :: UinputCfg
defUinputCfg = $WUinputCfg :: CInt -> CInt -> CInt -> String -> Maybe String -> UinputCfg
UinputCfg
  { _vendorCode :: CInt
_vendorCode     = 0x1235
  , _productCode :: CInt
_productCode    = 0x5679
  , _productVersion :: CInt
_productVersion = 0x0000
  , _keyboardName :: String
_keyboardName   = "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 :: UinputCfg -> RIO e (Acquire KeySink)
uinputSink c :: 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 :: Fd -> UinputCfg -> m Int
acquire_uinput_keysink (Fd h :: CInt
h) c :: UinputCfg
c = IO Int -> m Int
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
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
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
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
productVersion)

-- | Release a Uinput device
release_uinput_keysink :: MonadIO m => Fd -> m Int
release_uinput_keysink :: Fd -> m Int
release_uinput_keysink (Fd h :: CInt
h) = IO Int -> m Int
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 :: UinputSink -> Fd -> LinuxKeyEvent -> RIO e ()
send_event u :: UinputSink
u (Fd h :: CInt
h) e :: LinuxKeyEvent
e@(LinuxKeyEvent (s' :: CInt
s', ns' :: CInt
ns', typ :: CInt
typ, c :: CInt
c, val :: CInt
val)) = do
  (IO Int -> RIO e Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> RIO e Int) -> IO Int -> RIO e Int
forall a b. (a -> b) -> a -> b
$ 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
keyboardName) LinuxKeyEvent
e


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

-- | Create a new UinputSink
usOpen :: HasLogFunc e => UinputCfg -> RIO e UinputSink
usOpen :: UinputCfg -> RIO e UinputSink
usOpen c :: UinputCfg
c = do
  Fd
fd <- 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 "/dev/uinput" OpenMode
WriteOnly 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
True Bool
False
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "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
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 (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)
postInit) ((String -> RIO e ()) -> RIO e ())
-> (String -> RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \cmd :: 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
$ "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 ()) -> RIO e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO e (Async ()) -> RIO e ())
-> (String -> RIO e (Async ())) -> String -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RIO e () -> RIO e (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (RIO e () -> RIO e (Async ()))
-> (String -> RIO e ()) -> String -> RIO e (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RIO e ()
forall (m :: * -> *). MonadIO m => String -> m ()
callCommand (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 :: UinputSink -> RIO e ()
usClose snk :: 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
$ \h :: 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 h :: Fd
h = 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
$ "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
keyboardName)

    close :: Fd -> m ()
close h :: Fd
h = do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ "Closing Uinput device file"
      IO () -> m ()
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 :: UinputSink -> KeyEvent -> RIO e ()
usWrite u :: UinputSink
u e :: 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
fd -> do
  SystemTime
now <- IO SystemTime -> RIO e SystemTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SystemTime -> RIO e SystemTime)
-> IO SystemTime -> RIO e SystemTime
forall a b. (a -> b) -> a -> b
$ 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