{-# LANGUAGE DeriveAnyClass #-}
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
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
foreign import ccall "ioctl_keyboard"
c_ioctl_keyboard :: CInt -> CInt -> IO CInt
ioctl_keyboard :: MonadIO m
=> Fd
-> Bool
-> m Int
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))
data KeyEventParser = KeyEventParser
{ KeyEventParser -> Int
_nbytes :: !Int
, KeyEventParser -> ByteString -> Either String LinuxKeyEvent
_prs :: !(B.ByteString -> Either String LinuxKeyEvent)
}
makeClassy ''KeyEventParser
defEventParser :: KeyEventParser
defEventParser :: KeyEventParser
defEventParser = Int
-> (ByteString -> Either String LinuxKeyEvent) -> KeyEventParser
KeyEventParser 24 ByteString -> Either String LinuxKeyEvent
decode64
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)
data DeviceSourceCfg = DeviceSourceCfg
{ DeviceSourceCfg -> String
_pth :: !FilePath
, DeviceSourceCfg -> KeyEventParser
_parser :: !KeyEventParser
}
makeClassy ''DeviceSourceCfg
data DeviceFile = DeviceFile
{ DeviceFile -> DeviceSourceCfg
_cfg :: !DeviceSourceCfg
, DeviceFile -> Fd
_fd :: !Fd
, DeviceFile -> Handle
_hdl :: !Handle
}
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
deviceSource :: HasLogFunc e
=> KeyEventParser
-> FilePath
-> 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
deviceSource64 :: HasLogFunc e
=> FilePath
-> 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
lsOpen :: (HasLogFunc e)
=> KeyEventParser
-> FilePath
-> 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
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
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