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
|
{-# 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
-- * 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.Num (Num(..))
import GHC.Show (Show(..))
-- | An I\/O event.
newtype Event = Event Int
deriving (Eq)
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
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 = ""
instance Monoid Event where
mempty = evtNothing
mappend = evtCombine
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 #-}
-- | A type alias for timeouts, specified in seconds.
data Timeout = Timeout {-# UNPACK #-} !Double
| Forever
deriving (Show)
-- | 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
, _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 '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
|
