forked from syndicate-lang/marketplace-ssh-2014
96 lines
3.7 KiB
Racket
96 lines
3.7 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(require racket/match)
|
|
(require racket/port)
|
|
|
|
(provide cook-io cook-output)
|
|
|
|
(define clear-to-eol "\033[2K")
|
|
(define kill-line (string-append "\r" clear-to-eol))
|
|
|
|
(struct buffer (chars consume-next-linefeed?) #:transparent)
|
|
|
|
(define (buffer-empty? b)
|
|
(null? (buffer-chars b)))
|
|
|
|
(define (buffer-adjust b new-chars)
|
|
(struct-copy buffer b
|
|
[chars new-chars]
|
|
[consume-next-linefeed? #f]))
|
|
|
|
(define (buffer-contents b)
|
|
(list->string (reverse (buffer-chars b))))
|
|
|
|
(define (update-buffer b key prompt k-eof k-complete k-ongoing)
|
|
(case key
|
|
((#\backspace #\rubout) ;; backspace = ^H = code 8; delete = code 127
|
|
(if (buffer-empty? b)
|
|
(k-ongoing b "")
|
|
(k-ongoing (buffer-adjust b (cdr (buffer-chars b))) "\b \b")))
|
|
((#\return) (k-complete (buffer-contents b) (buffer '() #t)))
|
|
((#\newline) (if (buffer-consume-next-linefeed? b)
|
|
(k-ongoing (struct-copy buffer b [consume-next-linefeed? #f]) "")
|
|
(k-complete (buffer-contents b) (buffer '() #f))))
|
|
((#\page) (k-ongoing b (string-append kill-line prompt (buffer-contents b))))
|
|
((#\004) ;; control-D, UNIX EOF
|
|
(if (buffer-empty? b)
|
|
(k-eof)
|
|
(k-ongoing b "")))
|
|
((#\033) ;; escape
|
|
(k-ongoing (buffer '() #f) (string-append kill-line prompt)))
|
|
(else (if (char-iso-control? key)
|
|
(k-ongoing b "")
|
|
(k-ongoing (buffer-adjust b (cons key (buffer-chars b))) (string key))))))
|
|
|
|
(define (cook-io raw-in raw-out prompt)
|
|
(define-values (cooked-in cooked-out) (make-pipe))
|
|
(define (close-ports)
|
|
(close-output-port cooked-out) ;; signal to our reader that we're not sending more
|
|
(close-input-port raw-in)) ;; signal to upstream that we are done reading
|
|
(thread
|
|
(lambda ()
|
|
(define input-buffer (make-bytes 4096))
|
|
(let loop ((b (buffer '() #f)))
|
|
(sync (handle-evt
|
|
(read-bytes-avail!-evt input-buffer raw-in)
|
|
(match-lambda
|
|
[(? eof-object?) ;; end-of-file on input
|
|
(close-ports)]
|
|
[(? number? count)
|
|
(let process-bytes ((i 0) (b b))
|
|
(if (>= i count)
|
|
(loop b)
|
|
(update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
|
|
close-ports
|
|
(lambda (line new-b)
|
|
(with-handlers ((exn:fail? void)) ;; ignore write errors
|
|
(write-string "\r\n" raw-out))
|
|
(write-string line cooked-out)
|
|
(newline cooked-out)
|
|
(process-bytes (+ i 1) new-b))
|
|
(lambda (new-b feedback)
|
|
(with-handlers ((exn:fail? void)) ;; ignore write errors
|
|
(write-string feedback raw-out))
|
|
(process-bytes (+ i 1) new-b)))))]))
|
|
(handle-evt
|
|
(port-closed-evt cooked-in)
|
|
(lambda (dummy) (close-ports)))))))
|
|
(values cooked-in (cook-output raw-out)))
|
|
|
|
(define (cook-output raw-out)
|
|
(define-values (cooked-in cooked-out) (make-pipe))
|
|
(thread
|
|
(lambda ()
|
|
(define buffer (make-bytes 4096))
|
|
(let loop ()
|
|
(define count (read-bytes-avail! buffer cooked-in))
|
|
(if (eof-object? count)
|
|
(begin (close-input-port cooked-in)
|
|
(close-output-port raw-out))
|
|
(let ((raw-data (regexp-replace* #"\n" (subbytes buffer 0 count) #"\r\n")))
|
|
(write-bytes raw-data raw-out)
|
|
(loop))))))
|
|
cooked-out)
|