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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
module GHC.Event.Internal
(
-- * Event back end
Backend
, backend
, delete
, poll
, modifyFd
, modifyFdOnce
-- * Event type
, Event
, evtRead
, evtWrite
, evtClose
, eventIs
-- * Lifetimes
, Lifetime(..)
, EventLifetime
, eventLifetime
, elLifetime
, elEvent
-- * Timeout type
, Timeout(..)
-- * Helpers
, throwErrnoIfMinus1NoRetry
) where
import Data.Bits ((.|.), (.&.))
import Data.OldList (foldl', filter, intercalate, null)
import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
import GHC.Base
import GHC.Word (Word64)
import GHC.Num (Num(..))
import GHC.Show (Show(..))
import Data.Semigroup.Internal (stimesMonoid)
-- | An I\/O event.
newtype Event = Event Int
deriving Eq -- ^ @since 4.4.0.0
evtNothing :: Event
evtNothing = Event 0
{-# INLINE evtNothing #-}
-- | Data is available to be read.
evtRead :: Event
evtRead = Event 1
{-# INLINE evtRead #-}
-- | The file descriptor is ready to accept a write.
evtWrite :: Event
evtWrite = Event 2
{-# INLINE evtWrite #-}
-- | Another thread closed the file descriptor.
evtClose :: Event
evtClose = Event 4
{-# INLINE evtClose #-}
eventIs :: Event -> Event -> Bool
eventIs (Event a) (Event b) = a .&. b /= 0
-- | @since 4.4.0.0
instance Show Event where
show e = '[' : (intercalate "," . filter (not . null) $
[evtRead `so` "evtRead",
evtWrite `so` "evtWrite",
evtClose `so` "evtClose"]) ++ "]"
where ev `so` disp | e `eventIs` ev = disp
| otherwise = ""
-- | @since 4.10.0.0
instance Semigroup Event where
(<>) = evtCombine
stimes = stimesMonoid
-- | @since 4.4.0.0
instance Monoid Event where
mempty = evtNothing
mconcat = evtConcat
evtCombine :: Event -> Event -> Event
evtCombine (Event a) (Event b) = Event (a .|. b)
{-# INLINE evtCombine #-}
evtConcat :: [Event] -> Event
evtConcat = foldl' evtCombine evtNothing
{-# INLINE evtConcat #-}
-- | The lifetime of an event registration.
--
-- @since 4.8.1.0
data Lifetime = OneShot -- ^ the registration will be active for only one
-- event
| MultiShot -- ^ the registration will trigger multiple times
deriving ( Show -- ^ @since 4.8.1.0
, Eq -- ^ @since 4.8.1.0
)
-- | The longer of two lifetimes.
elSupremum :: Lifetime -> Lifetime -> Lifetime
elSupremum OneShot OneShot = OneShot
elSupremum _ _ = MultiShot
{-# INLINE elSupremum #-}
-- | @since 4.10.0.0
instance Semigroup Lifetime where
(<>) = elSupremum
stimes = stimesMonoid
-- | @mappend@ takes the longer of two lifetimes.
--
-- @since 4.8.0.0
instance Monoid Lifetime where
mempty = OneShot
-- | A pair of an event and lifetime
--
-- Here we encode the event in the bottom three bits and the lifetime
-- in the fourth bit.
newtype EventLifetime = EL Int
deriving ( Show -- ^ @since 4.8.0.0
, Eq -- ^ @since 4.8.0.0
)
-- | @since 4.11.0.0
instance Semigroup EventLifetime where
EL a <> EL b = EL (a .|. b)
-- | @since 4.8.0.0
instance Monoid EventLifetime where
mempty = EL 0
eventLifetime :: Event -> Lifetime -> EventLifetime
eventLifetime (Event e) l = EL (e .|. lifetimeBit l)
where
lifetimeBit OneShot = 0
lifetimeBit MultiShot = 8
{-# INLINE eventLifetime #-}
elLifetime :: EventLifetime -> Lifetime
elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot
{-# INLINE elLifetime #-}
elEvent :: EventLifetime -> Event
elEvent (EL x) = Event (x .&. 0x7)
{-# INLINE elEvent #-}
-- | A type alias for timeouts, specified in nanoseconds.
data Timeout = Timeout {-# UNPACK #-} !Word64
| Forever
deriving Show -- ^ @since 4.4.0.0
-- | Event notification backend.
data Backend = forall a. Backend {
_beState :: !a
-- | Poll backend for new events. The provided callback is called
-- once per file descriptor with new events.
, _bePoll :: a -- backend state
-> Maybe Timeout -- timeout in milliseconds ('Nothing' for non-blocking poll)
-> (Fd -> Event -> IO ()) -- I/O callback
-> IO Int
-- | Register, modify, or unregister interest in the given events
-- on the given file descriptor.
, _beModifyFd :: a
-> Fd -- file descriptor
-> Event -- old events to watch for ('mempty' for new)
-> Event -- new events to watch for ('mempty' to delete)
-> IO Bool
-- | Register interest in new events on a given file descriptor, set
-- to be deactivated after the first event.
, _beModifyFdOnce :: a
-> Fd -- file descriptor
-> Event -- new events to watch
-> IO Bool
, _beDelete :: a -> IO ()
}
backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> Event -> IO Bool)
-> (a -> Fd -> Event -> IO Bool)
-> (a -> IO ())
-> a
-> Backend
backend bPoll bModifyFd bModifyFdOnce bDelete state =
Backend state bPoll bModifyFd bModifyFdOnce bDelete
{-# INLINE backend #-}
poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll (Backend bState bPoll _ _ _) = bPoll bState
{-# INLINE poll #-}
-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
{-# INLINE modifyFd #-}
-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
{-# INLINE modifyFdOnce #-}
delete :: Backend -> IO ()
delete (Backend bState _ _ _ bDelete) = bDelete bState
{-# INLINE delete #-}
-- | Throw an 'Prelude.IOError' corresponding to the current value of
-- 'getErrno' if the result value of the 'IO' action is -1 and
-- 'getErrno' is not 'eINTR'. If the result value is -1 and
-- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result
-- value is returned.
throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1NoRetry loc f = do
res <- f
if res == -1
then do
err <- getErrno
if err == eINTR then return 0 else throwErrno loc
else return res
|
