0 | ||| Posix-compliant file polling based on the `poll` system call.
  1 | |||
  2 | ||| This form of file polling takes linear time with relation for
  3 | ||| the number of file descriptors to be polled, which is perfectly
  4 | ||| fine for polling small numbers of file descriptors. For polling
  5 | ||| hundreds or thousands of file descriptors, consider using
  6 | ||| the poller from async-epoll, which is based on the Linux-only
  7 | ||| `epoll` system calls.
  8 | module IO.Async.Loop.Poller
  9 |
 10 | import Data.Linear.Ref1
 11 | import Data.SortedMap
 12 |
 13 | import IO.Async.Internal.Ref
 14 |
 15 | import System
 16 | import System.Clock
 17 | import System.Posix.File.Prim
 18 | import System.Posix.Poll.Prim
 19 |
 20 | %default total
 21 |
 22 | --------------------------------------------------------------------------------
 23 | -- Utilities
 24 | --------------------------------------------------------------------------------
 25 |
 26 | export
 27 | dieOnErr : E1 World [Errno] a -> IO1 a
 28 | dieOnErr act t =
 29 |   case act t of
 30 |     R r        t => r # t
 31 |     E (Here x) t => ioToF1 (die "Error: \{errorText x} (\{errorName x})") t
 32 |
 33 | public export
 34 | 0 FileHandle : Type
 35 | FileHandle = PollEvent -> IO1 ()
 36 |
 37 | export
 38 | hdummy : FileHandle
 39 | hdummy = \_ => unit1
 40 |
 41 | --------------------------------------------------------------------------------
 42 | -- Poller
 43 | --------------------------------------------------------------------------------
 44 |
 45 | public export
 46 | record Poller where
 47 |   constructor MkPoller
 48 |   poll     : IO1 ()
 49 |   pollWait : Clock Duration -> IO1 ()
 50 |   release  : IO1 ()
 51 |   pollFile :
 52 |        (fd        : Fd)
 53 |     -> (ev        : PollEvent)
 54 |     -> (autoClose : Bool)
 55 |     -> (cb        : Either Errno PollEvent -> IO1 ())
 56 |     -> IO1 (IO1 ())
 57 |
 58 | --------------------------------------------------------------------------------
 59 | -- Posix compatible polling via `poll`
 60 | --------------------------------------------------------------------------------
 61 |
 62 | -- State used for file descriptor polling
 63 | record Posix where
 64 |   constructor PX
 65 |   ||| File event handles. This are invoked after receiving
 66 |   ||| events from `epoll`
 67 |   handles  : IORef (SortedMap Fd (PollEvent, FileHandle))
 68 |
 69 | parameters (p : Posix)
 70 |
 71 |   %inline
 72 |   getHandle : Fd -> IO1 (Maybe (PollEvent,FileHandle))
 73 |   getHandle fd t =
 74 |     let m # t := read1 p.handles t
 75 |      in lookup fd m # t
 76 |
 77 |   handleEvs : List PollPair -> IO1 ()
 78 |   handleEvs []             t = () # t
 79 |   handleEvs (PP fd ev::es) t =
 80 |     let Just (_,h) # t := getHandle fd t | Nothing # t => handleEvs es t
 81 |         _ # t := h ev t
 82 |      in handleEvs es t
 83 |
 84 |   -- Uses `poll` to poll for file events.
 85 |   pollWaitImpl : (timeout : Clock Duration) -> IO1 ()
 86 |   pollWaitImpl to t =
 87 |     let ms      := seconds to * 1000 + (nanoseconds to `div` 1_000_000)
 88 |         fds # t := read1 p.handles t
 89 |         pairs   := (\(fd,e,_) => PP fd e) <$> kvList fds
 90 |         vs # t  := dieOnErr (pollList pairs (cast ms)) t
 91 |      in handleEvs vs t
 92 |
 93 |   pollImpl : IO1 ()
 94 |   pollImpl t =
 95 |     let m # t := read1 p.handles t
 96 |      in if null m then () # t else pollWaitImpl (makeDuration 0 0) t
 97 |
 98 | cleanup : Posix -> Fd -> IO1 ()
 99 | cleanup p fd t =
100 |   assert_total $
101 |    let x    # t := read1 p.handles t
102 |        True # t := caswrite1 p.handles x (delete fd x) t | _ # t => cleanup p fd t
103 |     in () # t
104 |
105 | insrt : Posix -> Fd -> PollEvent -> FileHandle -> IO1 ()
106 | insrt p fd ev fh t =
107 |   assert_total $
108 |    let x    # t := read1 p.handles t
109 |        True # t := caswrite1 p.handles x (insert fd (ev,fh) x) t | _ # t => cleanup p fd t
110 |     in () # t
111 |
112 | --------------------------------------------------------------------------------
113 | -- Interfaces
114 | --------------------------------------------------------------------------------
115 |
116 | parameters (p         : Posix)
117 |            (fd        : Fd)
118 |            (ev        : PollEvent)
119 |            (autoClose : Bool)
120 |            (cb        : Either Errno PollEvent -> IO1 ())
121 |
122 |   -- close the file descriptor if `autoClose` is set to `True`
123 |   -- this must be done *after* invoking `cb`.
124 |   %inline
125 |   closefd : IO1 ()
126 |   closefd = when1 autoClose (toF1 $ close' fd)
127 |
128 |   -- invokes `cleanup` before running the file handle, and closes
129 |   -- the file descriptor in case `autoClose` is set to `True`.
130 |   %inline
131 |   act : FileHandle
132 |   act e t =
133 |     let _ # t := Poller.cleanup p fd t
134 |         _ # t := cb (Right e) t
135 |      in closefd t
136 |
137 |   -- cancelation hook: like `act` but without invoking the callback
138 |   %inline
139 |   cncl : FileHandle
140 |   cncl e t =
141 |     let _ # t := Poller.cleanup p fd t
142 |      in closefd t
143 |
144 |   pollFileImpl : IO1 (IO1 ())
145 |   pollFileImpl t =
146 |     let -- atomic boolean flag indicating if the handle is still active
147 |         -- this will be atomically set to `False` (using `once`)
148 |         -- before running or canceling the file handle
149 |         --
150 |         -- `cleanup` needs to be atomic because there is a race condition
151 |         -- between running the file handle once an event is ready and
152 |         -- cancelation, which might happen externally and from a different
153 |         -- thread
154 |         r  # t := ref1 True t
155 |         _  # t := insrt p fd ev (once r . act) t
156 |      in once r (cleanup p fd) # t
157 |
158 | ||| initialize the state of a posix-compatible poller.
159 | export
160 | posixPoller : IO1 Poller
161 | posixPoller t =
162 |   let ref # t := ref1 SortedMap.empty t
163 |       px      := PX ref
164 |    in MkPoller (pollImpl px) (pollWaitImpl px) unit1 (pollFileImpl px) # t
165 |