UinputSink.hs

{-# 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 Exception

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

makeClassyPrisms ''UinputSinkError


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

-- | Configuration of the Uinput keyboard to instantiate
data UinputCfg = UinputCfg
  { _vendorCode     :: !CInt
  , _productCode    :: !CInt
  , _productVersion :: !CInt
  , _keyboardName   :: !String
  , _postInit       :: !(Maybe String)
  } deriving (Eq, Show)
makeClassy ''UinputCfg

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

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

-- | Return a new uinput 'KeySink' with extra options
uinputSink :: HasLogFunc e => UinputCfg -> RIO e (Acquire KeySink)
uinputSink c = mkKeySink (usOpen c) usClose 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 h) c = liftIO $ do
  cstr <- newCString $ c^.keyboardName
  c_acquire_uinput_keysink h cstr
    (c^.vendorCode) (c^.productCode) (c^.productVersion)

-- | Release a Uinput device
release_uinput_keysink :: MonadIO m => Fd -> m Int
release_uinput_keysink (Fd h) = liftIO $ c_release_uinput_keysink h

-- | Using a Uinput device, send a LinuxKeyEvent to the Linux kernel
send_event :: ()
  => UinputSink
  -> Fd
  -> LinuxKeyEvent
  -> RIO e ()
send_event u (Fd h) e@(LinuxKeyEvent (s', ns', typ, c, val)) = do
  liftIO (c_send_event h typ c val s' ns')
    `onErr` SinkEncodeError (u^.cfg.keyboardName) e


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

-- | Create a new UinputSink
usOpen :: HasLogFunc e => UinputCfg -> RIO e UinputSink
usOpen c = do
  when (null $ c ^. keyboardName) $ throwM EmptyNameError
  fd <- liftIO $ openFd "/dev/uinput"
    WriteOnly
#if !MIN_VERSION_unix(2,8,0)
    Nothing
#endif
    defaultFileFlags
  logInfo "Registering Uinput device"
  acquire_uinput_keysink fd c `onErr` UinputRegistrationError (c ^. keyboardName)
  flip (maybe $ pure ()) (c^.postInit) $ \cmd -> do
    logInfo $ "Running UinputSink command: " <> displayShow cmd
    void . async . spawnCommand $ cmd
  UinputSink c <$> newMVar fd

-- | Close a 'UinputSink'
usClose :: HasLogFunc e => UinputSink -> RIO e ()
usClose snk = withMVar (snk^.st) $ \h -> finally (release h) (close h)
  where
    release h = do
      logInfo "Unregistering Uinput device"
      release_uinput_keysink h
        `onErr` UinputReleaseError (snk^.cfg.keyboardName)

    close h = do
      logInfo "Closing Uinput device file"
      liftIO $ closeFd 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 u e = withMVar (u^.st) $ \fd -> do
  now <- liftIO getSystemTime
  send_event u fd . toLinuxKeyEvent e $ now
  send_event u fd . sync              $ now