mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

Prevent TOCTTOU bugs in suspendable ports

Browse source 
* module/ice-9/suspendable-ports.scm: Prevent TOCTTOU bugs by
  additionally returning the buffer and offset when we compute an
  amount-buffered.
This commit is contained in:
Andy Wingo 2017-02-08 11:22:22 +01:00
parent ecdff904cb
commit 8a4774dec8
1 changed files with 86 additions and 81 deletions
Download patch file Download diff file Expand all files Collapse all files

167
module/ice-9/suspendable-ports.scm
View file

@ -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)