Commit 2b66d4ac authored by james's avatar james
Browse files

Start on implementing Telnet stream for real. It's just a wrapper class around

the actual stream, rather than directly inherited from the stream. This means
we have to implement all the damned stream functions for it, but oh well. Most
of them will just be wrappers anyway.

Finished renaming old NVT constants. Now we say +CMD-FOO+ and +OPT-FOO+.

Start of work on option and command handling. PROCESS-TELNET-COMMAND does
things with IAC sequences. SUBNEGOTIATE-OPTION handles IAC SB ... IAC SE.
Example is SUBNEGOTIATE-NAWS-OPTION which puts together NAWS width and height
and passes them to a user-supplied support function.

There's something wrong with how commands and options are processed, one
character at a time. I think it might be better to snarf an entire IAC
sequence (maybe two, if we see eg IAC SB) and then process that all at once.
This bears consideration. It would certainly allow us to recover cleanly from
corruption, and would probably be faster too.

Another issue pending is whether the stream should be bytes rather than
characters. Using characters could cause problems if Unicode appeared.
parent 489508b8
;;;; ltelnetd.lisp -- Lisp Telnet daemon.
;;;;
;;;; $Id: ltelnetd.lisp,v 1.1.1.1 2004/01/22 16:01:06 james Exp $
;;;; $Id: ltelnetd.lisp,v 1.3 2004/01/23 08:45:28 james Exp $
;;;;
;;;; Copyfnord (K) 3170 James A. Crippen <james@unlambda.com>,
;;;; Martin Rydstrom <rydis@cd.chalmers.se>
......@@ -311,41 +311,60 @@ in LISTENER."
;;;;;; Telnet Stream
;;
;;; FIXME: What should this class really inherit from? In SBCL we use
;;; SB-BSD-SOCKETS:SOCKET-MAKE-STREAM, but this gives us a FILE-STREAM (aka
;;; FD-STREAM) which might not be what we want.
;;;
;;; Networking in Lisp is so icky nowadays. How I pine for the Lisp Machines.
(defclass telnet-stream (file-stream)
((transmit-mode :initform :character :type (member :character :line)
:accessor stream-transmit-mode)
;;; TELNET-STREAM isn't a real stream. It merely pretends to be one by
;;; implementing all the applicable stream functions, and functions as a
;;; wrapper around whatever stream has been created from the socket.
(defclass telnet-stream ()
((stream :accessor telnet-stream-stream :type (or file-stream null))
(unread-chars :accessor telnet-stream-unread-chars)
(transmit-mode :initform :character :type (member :character :line)
:accessor telnet-stream-transmit-mode)
(command-mode :initform nil :type (member nil t)
:accessor stream-command-mode)
(got-iac :initform nil :type (member nil t)
:accessor stream-got-iac)
:accessor telnet-stream-command-mode)
(remote-echo :initform t :type (member nil t)
:accessor stream-remote-echo)
:accessor telnet-stream-remote-echo)
(local-suppress-go-ahead :initform nil :type (member nil t)
:accessor stream-local-suppress-go-ahead)
:accessor telnet-stream-local-suppress-go-ahead)
(remote-suppress-go-ahead :initform nil :type (member nil t)
:accessor stream-remote-suppress-go-ahead)
(resume-buffer :initform nil :accessor stream-resume-buffer)
(resume-urgent-length :initform nil :accessor stream-urgent-length)
;; This should probably be off for use with CL-TERMINFO.
(convert-telnet-characters :initform nil :type (member nil t)
:accessor stream-convert-telnet-characters)))
(defmethod read-char ((stream telnet-stream))
(let ((char (peek-char stream)))
(if (char-equal char +nvt-iac+)
(process-telnet-command-stream stream))))
(defmethod write-char ((stream telnet-stream) char)
(when (and (eq (stream-remote-echo stream) t)
(eq (stream-convert-telnet-characters stream) t))
(case char
(#\Backspace (send-telnet-command-erase-char stream))
(#\Newline (send-telnet-command-newline-char stream)))))
:accessor telnet-stream-remote-suppress-go-ahead)
(resume-buffer :initform nil :accessor telnet-stream-resume-buffer)
(resume-urgent-length :initform nil :accessor telnet-stream-urgent-length)
(naws-support-function :initform nil :type (or function null)
:accessor telnet-stream-naws-support-function)))
;;; NOTE: READ-CHAR and PROCESS-TELNET-COMMAND are incestuous.
(defmethod read-char ((stream telnet-stream) &optional eof-error-p eof-value recursive-p)
(declare (ignore eof-error-p eof-value recursive-p)) ;FIXME: Use these instead of ignoring.
(let* ((unread-chars (telnet-stream-unread-chars stream))
(strm (telnet-stream-stream stream))
(char (if unread-chars
(let ((c (car unread-chars)))
(setf unread-chars (cdr unread-chars))
c)
(read-char strm)))) ;read from the real stream
;; If we read IAC then process the command. If that command returns IAC
;; then we return IAC (ie, IAC was escaped). Otherwise just return the
;; char.
(if (not (char-equal char +iac+))
char
(let ((foo (process-telnet-command stream)))
(if (char-equal foo +iac+)
foo
;; Our READ-CHAR, so we get any additional UNREAD-CHARS.
(read-char stream))))))
(defmethod discard-char ((stream telnet-stream))
"Silently discards a character from STREAM. Returns NIL."
(let* ((unread-chars (telnet-stream-unread-chars stream))
(strm (telnet-stream-stream stream)))
(if unread-chars
(setf unread-chars (cdr unread-chars))
(read-char strm)))
(values))
(defmethod unread-char (character (stream telnet-stream))
(push character (telnet-stream-unread-chars stream)))
;;
......@@ -375,7 +394,7 @@ in LISTENER."
(defconstant +cmd-se+ (code-char 240) "Subnegotiation End")
(defconstant +cmd-nop+ (code-char 241) "No Operation")
(defconstant +cmd-dm+ (code-char 242) "Data Mark")
(defconstant +cmd-break+ (code-char 243) "Break")
(defconstant +cmd-brk+ (code-char 243) "Break")
(defconstant +cmd-ip+ (code-char 244) "Interrupt Process")
(defconstant +cmd-ao+ (code-char 245) "Abort Output")
(defconstant +cmd-ayt+ (code-char 246) "Are You There?")
......@@ -392,39 +411,80 @@ in LISTENER."
;;;
;;; These are options which may only be received as part of an option
;;; negotiation (ie, preceded by "IAC {DO,DONT,WILL,WONT,SB,SE}").
(defconstant +nvt-echo+ (code-char 1) "Echo")
(defconstant +nvt-supress-go-ahead+ (code-char 3) "Suppress Go Ahead")
(defconstant +nvt-status+ (code-char 5) "Status")
(defconstant +nvt-timing-mark+ (code-char 6) "Timing Mark")
(defconstant +nvt-terminal-type+ (code-char 24) "Terminal Type")
(defconstant +nvt-end-of-record+ (code-char 25) "End of Record")
(defconstant +nvt-ttyloc+ (code-char 26) "Terminal Location Number")
(defconstant +nvt-naws+ (code-char 31) "Negotiate About Window Size")
(defconstant +nvt-terminal-speed+ (code-char 32) "Terminal Speed")
(defconstant +nvt-toggle-flow-ctrl+ (code-char 33) "Toggle Flow Control")
(defconstant +nvt-linemode+ (code-char 34) "Line Mode")
(defconstant +nvt-xdisploc+ (code-char 35) "X Display Location")
(defconstant +nvt-environ+ (code-char 36) "Environment")
(defconstant +nvt-eor+ (code-char 239) "End of Record")
(defconstant +nvt-exopl+ (code-char 255) "Extended Options List")
(defconstant +nvt-randomly-lose+ (code-char 256) "Randomly Lose")
(defconstant +nvt-submsg+ (code-char 257) "Subliminal Message")
(defconstant +nvt-is+ (code-char 0) "IS")
(defconstant +opt-echo+ (code-char 1) "Echo")
(defconstant +opt-supress-go-ahead+ (code-char 3) "Suppress Go Ahead")
(defconstant +opt-status+ (code-char 5) "Status")
(defconstant +opt-timing-mark+ (code-char 6) "Timing Mark")
(defconstant +opt-terminal-type+ (code-char 24) "Terminal Type")
(defconstant +opt-end-of-record+ (code-char 25) "End of Record")
(defconstant +opt-ttyloc+ (code-char 26) "Terminal Location Number")
(defconstant +opt-naws+ (code-char 31) "Negotiate About Window Size")
(defconstant +opt-terminal-speed+ (code-char 32) "Terminal Speed")
(defconstant +opt-toggle-flow-ctrl+ (code-char 33) "Toggle Flow Control")
(defconstant +opt-linemode+ (code-char 34) "Line Mode")
(defconstant +opt-xdisploc+ (code-char 35) "X Display Location")
(defconstant +opt-environ+ (code-char 36) "Environment")
(defconstant +opt-eor+ (code-char 239) "End of Record")
(defconstant +opt-exopl+ (code-char 255) "Extended Options List")
(defconstant +opt-randomly-lose+ (code-char 256) "Randomly Lose")
(defconstant +opt-submsg+ (code-char 257) "Subliminal Message")
(defconstant +opt-is+ (code-char 0) "IS")
;;
;;;;;; Command and Option Processing.
;;;;;; Command and Option Handling.
;;
(defmethod negotiate-telnet-options ((stream telnet-stream))
())
(defmethod process-telnet-command ((stream telnet-stream))
"Processes a Telnet protocol command. Expects STREAM to have command
contents in queue without preceding IAC character. If command is another IAC
then it's an escaped #xFF, which we return. Otherwise return NIL."
(let ((old-cmd-mode (telnet-stream-command-mode stream)))
(unwind-protect
(progn
(setf (telnet-stream-command-mode stream) t)
;; Our READ-CHAR, not CL READ-CHAR.
(let ((c (read-char stream)))
(case c
(+iac+ (return-from process-telnet-command +iac+))
(+cmd-nop+ (return-from process-telnet-command nil))
(+cmd-dm+)
(+cmd-brk+)
(+cmd-ip+)
(+cmd-ao+)
(+cmd-ayt+ (send-ayt-response stream))
((+cmd-bell+ +cmd-ec+ +cmd-el+)
;; Character funkage here.
)
(+cmd-ga+)
(+cmd-sb+ (subnegotiate-option stream))
(+cmd-se+)
((+cmd-will+ +cmd-wont+ +cmd-do+ +cmd-dont+)
(unread-char c stream)
(process-telnet-option stream))
())))
(setf (telnet-stream-command-mode stream) old-cmd-mode))
(values)))
(defmethod process-telnet-option ((stream telnet-stream))
)
(defmethod subnegotiate-option ((stream telnet-stream))
(let ((c (read-char stream)))
(case c
(+opt-naws+ (subnegotiate-naws-option stream)))))
(defmethod process-telnet-command ((stream telnet-stream))
"Processes a Telnet protocol command. Expects STREAM to have command contents
in queue without preceding +NVT-IAC+ character. Returns STREAM."
(setf (stream-command-mode stream) t)
)
(defmethod subnegotiate-naws-option ((stream telnet-stream))
(let* ((strm (telnet-stream-stream stream))
;; Read from real stream since IAC is irrelevant for next 4 bytes.
(width (logior (ash (char-code (read-char strm))) 8)
(char-code (read-char strm))))
(height (logior (ash (char-code (read-char strm)) 8)
(char-code (read-char strm)))))
(funcall (telnet-stream-naws-support-function stream) width height)
;; FIXME: This is totally wrong.
(discard-char stream) ;IAC
(discard-char stream) ;SE
(values)))
(defmethod send-telnet-command ((command character) (stream telnet-stream))
(write-char +iac+ stream)
(write-char command stream))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment