{-# LANGUAGE DeriveAnyClass #-}
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
type SinkId = String
data UinputSinkError
= UinputRegistrationError SinkId
| UinputReleaseError SinkId
| SinkEncodeError SinkId LinuxKeyEvent
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
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
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
}
data UinputSink = UinputSink
{ UinputSink -> UinputCfg
_cfg :: UinputCfg
, UinputSink -> MVar Fd
_st :: MVar Fd
}
makeLenses ''UinputSink
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
foreign import ccall "acquire_uinput_keysink"
c_acquire_uinput_keysink
:: CInt
-> CString
-> CInt
-> CInt
-> CInt
-> 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
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_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
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
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
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
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