forked from kmonad/kmonad
-
Notifications
You must be signed in to change notification settings - Fork 0
/
DeviceSource.hs
165 lines (136 loc) · 5.57 KB
/
DeviceSource.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-|
Module : KMonad.Keyboard.IO.Linux.DeviceSource
Description : Load and acquire a linux /dev/input device
Copyright : (c) David Janssen, 2019
License : MIT
Maintainer : [email protected]
Stability : experimental
Portability : portable
-}
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
--------------------------------------------------------------------------------
-- $err
data DeviceSourceError
= IOCtlGrabError FilePath
| IOCtlReleaseError FilePath
| KeyIODecodeError String
deriving Exception
instance Show DeviceSourceError where
show (IOCtlGrabError pth) = "Could not perform IOCTL grab on: " <> pth
show (IOCtlReleaseError pth) = "Could not perform IOCTL release on: " <> pth
show (KeyIODecodeError msg) = "KeyEvent decode failed with msg: " <> msg
makeClassyPrisms ''DeviceSourceError
--------------------------------------------------------------------------------
-- $ffi
foreign import ccall "ioctl_keyboard"
c_ioctl_keyboard :: CInt -> CInt -> IO CInt
-- | Perform an IOCTL operation on an open keyboard handle
ioctl_keyboard :: MonadIO m
=> Fd -- ^ Descriptor to open keyboard file (like /dev/input/eventXX)
-> Bool -- ^ True to grab, False to ungrab
-> m Int -- ^ Return the exit code
ioctl_keyboard (Fd h) b = fromIntegral <$>
liftIO (c_ioctl_keyboard h (if b then 1 else 0))
--------------------------------------------------------------------------------
-- $decoding
-- | A 'KeyEventParser' describes how to read and parse 'LinuxKeyEvent's from
-- the binary data-stream provided by the device-file.
data KeyEventParser = KeyEventParser
{ _nbytes :: !Int
-- ^ Size of 1 input event in bytes
, _prs :: !(B.ByteString -> Either String LinuxKeyEvent)
-- ^ Function to convert bytestring to event
}
makeClassy ''KeyEventParser
-- | Default configuration for parsing keyboard events
defEventParser :: KeyEventParser
defEventParser = KeyEventParser 24 decode64
-- | The KeyEventParser that works on my 64-bit Linux environment
decode64 :: B.ByteString -> Either String LinuxKeyEvent
decode64 bs = linuxKeyEvent . fliptup <$> result
where
result :: Either String (Int32, Word16, Word16, Word64, Word64)
result = B.decode . B.reverse $ bs
fliptup (a, b, c, d, e) = (e, d, c, b, a)
--------------------------------------------------------------------------------
-- $types
-- | Configurable components of a DeviceSource
data DeviceSourceCfg = DeviceSourceCfg
{ _pth :: !FilePath -- ^ Path to the event-file
, _parser :: !KeyEventParser -- ^ The method used to decode events
}
makeClassy ''DeviceSourceCfg
-- | Collection of data used to read from linux input.h event stream
data DeviceFile = DeviceFile
{ _cfg :: !DeviceSourceCfg -- ^ Configuration settings
, _fd :: !Fd -- ^ Posix filedescriptor to the device file
, _hdl :: !Handle -- ^ Haskell handle to the device file
}
makeClassy ''DeviceFile
instance HasDeviceSourceCfg DeviceFile where deviceSourceCfg = cfg
instance HasKeyEventParser DeviceFile where keyEventParser = cfg.parser
-- | Open a device file
deviceSource :: HasLogFunc e
=> KeyEventParser -- ^ The method by which to read and decode events
-> FilePath -- ^ The filepath to the device file
-> RIO e (Acquire KeySource)
deviceSource pr pt = mkKeySource (lsOpen pr pt) lsClose lsRead
-- | Open a device file on a standard linux 64 bit architecture
deviceSource64 :: HasLogFunc e
=> FilePath -- ^ The filepath to the device file
-> RIO e (Acquire KeySource)
deviceSource64 = deviceSource defEventParser
--------------------------------------------------------------------------------
-- $io
-- | Open the keyboard, perform an ioctl grab and return a 'DeviceFile'. This
-- can throw an 'IOException' if the file cannot be opened for reading, or an
-- 'IOCtlGrabError' if an ioctl grab could not be properly performed.
lsOpen :: (HasLogFunc e)
=> KeyEventParser -- ^ The method by which to decode events
-> FilePath -- ^ The path to the device file
-> RIO e DeviceFile
lsOpen pr pt = do
#if MIN_VERSION_unix(2,8,0)
h <- liftIO . openFd pt ReadOnly $
#else
h <- liftIO . openFd pt ReadOnly Nothing $
#endif
OpenFileFlags False False False False False
hd <- liftIO $ fdToHandle h
logInfo "Initiating ioctl grab"
ioctl_keyboard h True `onErr` IOCtlGrabError pt
return $ DeviceFile (DeviceSourceCfg pt pr) h hd
-- | Release the ioctl grab and close the device file. This can throw an
-- 'IOException' if the handle to the device cannot be properly closed, or an
-- 'IOCtlReleaseError' if the ioctl release could not be properly performed.
lsClose :: (HasLogFunc e) => DeviceFile -> RIO e ()
lsClose src = do
logInfo "Releasing ioctl grab"
ioctl_keyboard (src^.fd) False `onErr` IOCtlReleaseError (src^.pth)
liftIO . closeFd $ src^.fd
-- | Read a bytestring from an open filehandle and return a parsed event. This
-- can throw a 'KeyIODecodeError' if reading from the 'DeviceFile' fails to
-- yield a parseable sequence of bytes.
lsRead :: (HasLogFunc e) => DeviceFile -> RIO e KeyEvent
lsRead src = do
bts <- B.hGet (src^.hdl) (src^.nbytes)
case src^.prs $ bts of
Right p -> case fromLinuxKeyEvent p of
Just e -> return e
Nothing -> lsRead src
Left s -> throwIO $ KeyIODecodeError s