Prevent TOCTTOU bugs in suspendable ports

* module/ice-9/suspendable-ports.scm: Prevent TOCTTOU bugs by
  additionally returning the buffer and offset when we compute an
  amount-buffered.

1 files changed, 86 insertions, 81 deletions

diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm
index bc84a4a98..8ff0ba029 100644
--- a/module/ice-9/suspendable-ports.scm
+++ b/module/ice-9/suspendable-ports.scm
@@ -124,10 +124,9 @@
     (and (eq? (peek-byte port) (bytevector-u8-ref bom 0))
          (call-with-values (lambda ()
                              (fill-input port (bytevector-length bom)))
-           (lambda (buf buffered)
+           (lambda (buf cur buffered)
              (and (<= (bytevector-length bom) buffered)
-                  (let ((bv (port-buffer-bytevector buf))
-                        (cur (port-buffer-cur buf)))
+                  (let ((bv (port-buffer-bytevector buf)))
                     (let lp ((i 1))
                       (if (= i (bytevector-length bom))
                           (begin
@@ -160,10 +159,10 @@
   (clear-stream-start-for-bom-read port io-mode)
   (let* ((buf (port-read-buffer port))
          (cur (port-buffer-cur buf))
-         (buffered (- (port-buffer-end buf) cur)))
+         (buffered (max (- (port-buffer-end buf) cur) 0)))
     (cond
      ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf))
-      (values buf buffered))
+      (values buf cur buffered))
      (else
       (unless (input-port? port)
         (error "not an input port" port))
@@ -186,13 +185,13 @@
                 (cond
                  ((zero? read)
                   (set-port-buffer-has-eof?! buf #t)
-                  (values buf buffered))
+                  (values buf 0 buffered))
                  (else
                   (let ((buffered (+ buffered read)))
                     (set-port-buffer-end! buf buffered)
                     (if (< buffered minimum-buffering)
                         (lp buffered)
-                        (values buf buffered)))))))))))))))
+                        (values buf 0 buffered)))))))))))))))
 
 (define* (force-output #:optional (port (current-output-port)))
   (unless (and (output-port? port) (not (port-closed? port)))
@@ -215,9 +214,8 @@
     (if (<= count buffered)
         (kfast buf (port-buffer-bytevector buf) cur buffered)
         (call-with-values (lambda () (fill-input port count))
-          (lambda (buf buffered)
-            (kslow buf (port-buffer-bytevector buf) (port-buffer-cur buf)
-                   buffered))))))
+          (lambda (buf cur buffered)
+            (kslow buf (port-buffer-bytevector buf) cur buffered))))))
 
 (define (peek-byte port)
   (peek-bytes port 1
@@ -258,7 +256,7 @@
     (define (take-already-buffered)
       (let* ((buf (port-read-buffer port))
              (cur (port-buffer-cur buf))
-             (buffered (- (port-buffer-end buf) cur)))
+             (buffered (max (- (port-buffer-end buf) cur) 0)))
         (port-buffer-take! 0 buf cur (min count buffered))))
     (define (trim-and-return len)
       (if (zero? len)
@@ -268,12 +266,12 @@
             partial)))
     (define (buffer-and-fill pos)
       (call-with-values (lambda () (fill-input port 1 'binary))
-        (lambda (buf buffered)
+        (lambda (buf cur buffered)
           (if (zero? buffered)
               (begin
                 (set-port-buffer-has-eof?! buf #f)
                 (trim-and-return pos))
-              (let ((pos (port-buffer-take! pos buf (port-buffer-cur buf)
+              (let ((pos (port-buffer-take! pos buf cur
                                             (min (- count pos) buffered))))
                 (if (= pos count)
                     ret
@@ -302,9 +300,15 @@
       (error "not an output port" port))
     (when (and (eq? (port-buffer-cur buf) end) (port-random-access? port))
       (flush-input port))
-    (bytevector-u8-set! bv end byte)
-    (set-port-buffer-end! buf (1+ end))
-    (when (= (1+ end) (bytevector-length bv)) (flush-output port))))
+    (cond
+     ((= end (bytevector-length bv))
+      ;; Multiple threads racing; race to flush, then retry.
+      (flush-output port)
+      (put-u8 port byte))
+     (else
+      (bytevector-u8-set! bv end byte)
+      (set-port-buffer-end! buf (1+ end))
+      (when (= (1+ end) (bytevector-length bv)) (flush-output port))))))
 
 (define* (put-bytevector port src #:optional (start 0)
                          (count (- (bytevector-length src) start)))
@@ -315,7 +319,7 @@
          (size (bytevector-length bv))
          (cur (port-buffer-cur buf))
          (end (port-buffer-end buf))
-         (buffered (- end cur)))
+         (buffered (max (- end cur) 0)))
     (when (and (eq? cur end) (port-random-access? port))
       (flush-input port))
     (cond
@@ -425,71 +429,73 @@
      (else 0)))
    (else 1)))
 
-(define (peek-char-and-len/utf8 port first-byte)
-  (define (bad-utf8 len)
-    (if (eq? (port-conversion-strategy port) 'substitute)
-        (values #\xFFFD len)
-        (decoding-error "peek-char" port)))
+(define (peek-char-and-next-cur/utf8 port buf cur first-byte)
   (if (< first-byte #x80)
-      (values (integer->char first-byte) 1)
+      (values (integer->char first-byte) buf (+ cur 1))
       (call-with-values (lambda ()
                           (fill-input port
                                       (cond
                                        ((<= #xc2 first-byte #xdf) 2)
                                        ((= (logand first-byte #xf0) #xe0) 3)
                                        (else 4))))
-        (lambda (buf buffering)
-          (let* ((bv (port-buffer-bytevector buf))
-                 (cur (port-buffer-cur buf)))
+        (lambda (buf cur buffering)
+          (let ((bv (port-buffer-bytevector buf)))
             (define (bad-utf8)
               (let ((len (bad-utf8-len bv cur buffering first-byte)))
                 (when (zero? len) (error "internal error"))
                 (if (eq? (port-conversion-strategy port) 'substitute)
-                    (values #\xFFFD len)
+                    (values #\xFFFD buf (+ cur len))
                     (decoding-error "peek-char" port))))
-            (decode-utf8 bv cur buffering first-byte values bad-utf8))))))
+            (decode-utf8 bv cur buffering first-byte
+                         (lambda (char len)
+                           (values char buf (+ cur len)))
+                         bad-utf8))))))
 
-(define (peek-char-and-len/iso-8859-1 port first-byte)
-  (values (integer->char first-byte) 1))
+(define (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte)
+  (values (integer->char first-byte) buf (+ cur 1)))
 
-(define (peek-char-and-len/iconv port first-byte)
+(define (peek-char-and-next-cur/iconv port)
   (let lp ((prev-input-size 0))
     (let ((input-size (1+ prev-input-size)))
       (call-with-values (lambda () (fill-input port input-size))
-        (lambda (buf buffered)
+        (lambda (buf cur buffered)
           (cond
            ((< buffered input-size)
             ;; Buffer failed to fill; EOF, possibly premature.
             (cond
              ((zero? prev-input-size)
-              (values the-eof-object 0))
+              (values the-eof-object buf cur))
              ((eq? (port-conversion-strategy port) 'substitute)
-              (values #\xFFFD prev-input-size))
+              (values #\xFFFD buf (+ cur prev-input-size)))
              (else
               (decoding-error "peek-char" port))))
            ((port-decode-char port (port-buffer-bytevector buf)
-                              (port-buffer-cur buf) input-size)
+                              cur input-size)
             => (lambda (char)
-                 (values char input-size)))
+                 (values char buf (+ cur input-size))))
            (else
             (lp input-size))))))))
 
-(define (peek-char-and-len port)
-  (let ((first-byte (peek-byte port)))
-    (if (not first-byte)
-        (values the-eof-object 0)
-        (case (%port-encoding port)
-          ((UTF-8)
-           (peek-char-and-len/utf8 port first-byte))
-          ((ISO-8859-1)
-           (peek-char-and-len/iso-8859-1 port first-byte))
-          (else
-           (peek-char-and-len/iconv port first-byte))))))
+(define (peek-char-and-next-cur port)
+  (define (have-byte buf bv cur buffered)
+    (let ((first-byte (bytevector-u8-ref bv cur)))
+      (case (%port-encoding port)
+        ((UTF-8)
+         (peek-char-and-next-cur/utf8 port buf cur first-byte))
+        ((ISO-8859-1)
+         (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte))
+        (else
+         (peek-char-and-next-cur/iconv port)))))
+  (peek-bytes port 1 have-byte
+              (lambda (buf bv cur buffered)
+                (if (< 0 buffered)
+                    (have-byte buf bv cur buffered)
+                    (values the-eof-object buf cur)))))
 
 (define* (peek-char #:optional (port (current-input-port)))
   (define (slow-path)
-    (call-with-values (lambda () (peek-char-and-len port))
-      (lambda (char len)
+    (call-with-values (lambda () (peek-char-and-next-cur port))
+      (lambda (char buf cur)
         char)))
   (define (fast-path buf bv cur buffered)
     (let ((u8 (bytevector-u8-ref bv cur))
@@ -532,15 +538,14 @@
     (advance-port-position! (port-buffer-position buf) char)
     char)
   (define (slow-path)
-    (call-with-values (lambda () (peek-char-and-len port))
-      (lambda (char len)
-        (let ((buf (port-read-buffer port)))
-          (set-port-buffer-cur! buf (+ (port-buffer-cur buf) len))
-          (if (eq? char the-eof-object)
-              (begin
-                (set-port-buffer-has-eof?! buf #f)
-                char)
-              (finish buf char))))))
+    (call-with-values (lambda () (peek-char-and-next-cur port))
+      (lambda (char buf cur)
+        (set-port-buffer-cur! buf cur)
+        (if (eq? char the-eof-object)
+            (begin
+              (set-port-buffer-has-eof?! buf #f)
+              char)
+            (finish buf char)))))
   (define (fast-path buf bv cur buffered)
     (let ((u8 (bytevector-u8-ref bv cur))
           (enc (%port-encoding port)))
@@ -559,29 +564,29 @@
               (lambda (buf bv cur buffered) (slow-path))))
 
 (define-inlinable (port-fold-chars/iso-8859-1 port proc seed)
-  (let fold-buffer ((buf (port-read-buffer port))
-                    (seed seed))
-    (let ((bv (port-buffer-bytevector buf))
-          (end (port-buffer-end buf)))
-      (let fold-chars ((cur (port-buffer-cur buf))
-                       (seed seed))
-        (cond
-         ((= end cur)
-          (call-with-values (lambda () (fill-input port))
-            (lambda (buf buffered)
-              (if (zero? buffered)
-                  (call-with-values (lambda () (proc the-eof-object seed))
-                    (lambda (seed done?)
-                      (if done? seed (fold-buffer buf seed))))
-                  (fold-buffer buf seed)))))
-         (else
-          (let ((ch (integer->char (bytevector-u8-ref bv cur)))
-                (cur (1+ cur)))
-            (set-port-buffer-cur! buf cur)
-            (advance-port-position! (port-buffer-position buf) ch)
-            (call-with-values (lambda () (proc ch seed))
-              (lambda (seed done?)
-                (if done? seed (fold-chars cur seed)))))))))))
+  (let* ((buf (port-read-buffer port))
+         (cur (port-buffer-cur buf)))
+    (let fold-buffer ((buf buf) (cur cur) (seed seed))
+      (let ((bv (port-buffer-bytevector buf))
+            (end (port-buffer-end buf)))
+        (let fold-chars ((cur cur) (seed seed))
+          (cond
+           ((= end cur)
+            (call-with-values (lambda () (fill-input port))
+              (lambda (buf cur buffered)
+                (if (zero? buffered)
+                    (call-with-values (lambda () (proc the-eof-object seed))
+                      (lambda (seed done?)
+                        (if done? seed (fold-buffer buf cur seed))))
+                    (fold-buffer buf cur seed)))))
+           (else
+            (let ((ch (integer->char (bytevector-u8-ref bv cur)))
+                  (cur (1+ cur)))
+              (set-port-buffer-cur! buf cur)
+              (advance-port-position! (port-buffer-position buf) ch)
+              (call-with-values (lambda () (proc ch seed))
+                (lambda (seed done?)
+                  (if done? seed (fold-chars cur seed))))))))))))
 
 (define-inlinable (port-fold-chars port proc seed)
   (case (%port-encoding port)