base: Fix hWaitForInput with timeout on POSIX

This was previously broken (#13252) by
f46369b8a1bf90a3bdc30f2b566c3a7e03672518, which ported the fdReady
function from `select` to `poll` and in so doing dropping support for
timeouts. Unfortunately, while `select` tells us the amount of time not
slept (on Linux anyways; it turns out this is implementation dependent),
`poll` does not give us this luxury. Consequently, we manually need to
track time slept in this case.

Unfortunately, portably measuring time is hard. Ideally we would use
`clock_gettime` with the monotonic clock here, but sadly this isn't
supported on most versions of Darwin. Consequently, we instead use
`gettimeofday`, running the risk of system time changes messing us up.

Test Plan: Validate

Reviewers: simonmar, austin, hvr

Reviewed By: simonmar

Subscribers: rwbarton, thomie

GHC Trac Issues: #13252

Differential Revision: https://phabricator.haskell.org/D3473

3 files changed, 35 insertions, 12 deletions

diff --git a/libraries/base/cbits/inputReady.c b/libraries/base/cbits/inputReady.c
index 230e592260..1530d5be90 100644
--- a/libraries/base/cbits/inputReady.c
+++ b/libraries/base/cbits/inputReady.c
@@ -9,11 +9,13 @@
 #include "HsBase.h"
 #if !defined(_WIN32)
 #include <poll.h>
+#include <sys/time.h>
 #endif
 
 /*
  * inputReady(fd) checks to see whether input is available on the file
- * descriptor 'fd'.  Input meaning 'can I safely read at least a
+ * descriptor 'fd' within 'msecs' milliseconds (or indefinitely if 'msecs' is
+ * negative). "Input is available" is defined as 'can I safely read at least a
  * *character* from this file object without blocking?'
  */
 int
@@ -21,23 +23,41 @@ fdReady(int fd, int write, int msecs, int isSock)
 {
 
 #if !defined(_WIN32)
+    struct pollfd fds[1];
 
-    // We only handle msecs == 0 on non-Windows, because this is the
-    // only case we need.  Non-zero waiting is handled by the IO manager.
-    if (msecs != 0) {
-        fprintf(stderr, "fdReady: msecs != 0, this shouldn't happen");
-        abort();
+    // if we need to track the then record the current time in case we are
+    // interrupted.
+    struct timeval tv0;
+    if (msecs > 0) {
+        if (gettimeofday(&tv0, NULL) != 0) {
+            fprintf(stderr, "fdReady: gettimeofday failed: %s\n",
+                    strerror(errno));
+            abort();
+        }
     }
 
-    struct pollfd fds[1];
-
     fds[0].fd = fd;
     fds[0].events = write ? POLLOUT : POLLIN;
     fds[0].revents = 0;
 
     int res;
-    while ((res = poll(fds, 1, 0)) < 0) {
-        if (errno != EINTR) {
+    while ((res = poll(fds, 1, msecs)) < 0) {
+        if (errno == EINTR) {
+            if (msecs > 0) {
+                struct timeval tv;
+                if (gettimeofday(&tv, NULL) != 0) {
+                    fprintf(stderr, "fdReady: gettimeofday failed: %s\n",
+                            strerror(errno));
+                    abort();
+                }
+
+                int elapsed = 1000 * (tv.tv_sec - tv0.tv_sec)
+                            + (tv.tv_usec - tv0.tv_usec) / 1000;
+                msecs -= elapsed;
+                if (msecs <= 0) return 0;
+                tv0 = tv;
+            }
+        } else {
             return (-1);
         }
     }
diff --git a/libraries/base/tests/T13525.hs b/libraries/base/tests/T13525.hs
index 1bb01b6a18..b4b589e0b4 100644
--- a/libraries/base/tests/T13525.hs
+++ b/libraries/base/tests/T13525.hs
@@ -1,7 +1,10 @@
+import System.Posix.Files
 import System.IO
 import System.Timeout
 
 main :: IO ()
 main = do
-    hWaitForInput stdin (5 * 1000)
+    createNamedPipe "test" accessModes
+    h <- openFile "test" ReadMode
+    hWaitForInput h (5 * 1000)
     return ()
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 69705bc91e..f3cdeaa512 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -212,4 +212,4 @@ test('T13191',
         , only_ways(['normal'])],
       compile_and_run,
       ['-O'])
-test('T13525', expect_broken(13525), compile_and_run, [''])
+test('T13525', normal, compile_and_run, [''])