;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: TELNET; -*- ;;;; --------------------------------------------------------------------------- ;;;; Title: A Minimal Implementation of the Telnet Protocol ;;;; Created: 2002-06-05 ;;;; Author: Gilbert Baumann ;;;; --------------------------------------------------------------------------- ;;;; (c) copyright 2002 by Gilbert Baumann ;; This is a minimal implementation of a telnet daemon. The idea is to ;; be able to log into a running Lisp system for an interactive ;; session. This also requires some minimal processing of TELNET ;; commands to have e.g. proper interrupt processing. ;; When a new TELNET session is initiated, a pair of processes is ;; created; one is the session itself and the other is just there to ;; do the I/O and to deliver interrupts to the session process. These ;; both processes are associated with each other by a ;; TELNET-SESSION-STREAM. ;;; TODO ;; - Hmm, where is the escaping of IAC? ;;; Wish List ;; - Since we now have two processes anyway, we perhaps could implement ;; proper a cursor as I last saw it on a CP/M 80 box. That is switch ;; the cursor on when the application awaits input and switch it off ;; when it is busy doing stuff. ;; - We want to implement proper option and suboption processing. At ;; least it should be possible to find out the remote terminal type, ;; it's line length and possibly also automatically reflecting the ;; terminal line length to the underlying stream. ;; - CLIM might be clever and find out the default server path by ;; reading the DISPLAY environment variable. ;; - Far future: tty-mode CLIM and optionally using the SUPDUP ;; protocol for proper keyboard handling. (defpackage :telnet (:use :clim-lisp :clim-sys) (:export #:start-telnet-listener)) (in-package :telnet) ;;;; First we need a couple of constants (defconstant +SE+ 240 "End of subnegotiation parameters.") (defconstant +NOP+ 241 "No operation.") (defconstant +Data-Mark+ 242 "The data stream portion of a Synch. This should always be accompanied by a TCP Urgent notification.") (defconstant +Break+ 243 "NVT character BRK.") (defconstant +Interrupt-Process+ 244 "The function IP.") (defconstant +Abort-output+ 245 "The function AO.") (defconstant +Are-You-There+ 246 "The function AYT.") (defconstant +Erase-character+ 247 "The function EC.") (defconstant +Erase-Line+ 248 "The function EL.") (defconstant +Go-ahead+ 249 "The GA signal.") (defconstant +SB+ 250 "Indicates that what follows is subnegotiation of the indicated option.") (defconstant +WILL+ 251 "Indicates the desire to begin performing, or confirmation that you are now performing, the indicated option.") (defconstant +WONT+ 252 "Indicates the refusal to perform, or continue performing, the indicated option.") (defconstant +DO+ 253 "Indicates the request that the other party perform, or confirmation that you are expecting the other party to perform, the indicated option.") (defconstant +DONT+ 254 "Indicates the demand that the other party stop performing, or confirmation that you are no longer expecting the other party to perform, the indicated option.") (defconstant +IAC+ 255 "Data Byte 255.") ;;;; (defclass telnet-session-stream (fundamental-character-input-stream fundamental-character-output-stream) ((io :initarg :io) (process :initarg :process :reader telnet-session-stream-process) (buffer :initform nil) (column :initform 0) (lock :initform (make-lock)) )) (defmethod stream-read-char ((stream telnet-session-stream)) (with-slots (lock buffer io) stream (loop (let ((c (with-lock-held (lock) (pop buffer)))) (when c (return c))) (process-wait "Waiting for Input" (lambda () (not (null buffer)))) ))) (defmethod stream-unread-char ((stream telnet-session-stream) character) (with-slots (lock buffer) stream (with-lock-held (lock) (push character buffer)) character)) (defmethod stream-write-char ((stream telnet-session-stream) character) (with-slots (io column) stream (cond ((char= character #\newline) (setf column 0) (write-byte 13 io) (write-byte 10 io)) (t (incf column) (write-byte (char-code character) io))))) (defmethod stream-finish-output ((stream telnet-session-stream)) (with-slots (io) stream (finish-output io))) (defmethod stream-force-output ((stream telnet-session-stream)) (with-slots (io) stream (force-output io))) (defmethod stream-line-column ((stream telnet-session-stream)) (with-slots (column) stream column)) (defun telnet-session-io-loop (stream) (with-slots (io process buffer lock) stream (handler-case (loop (let ((c (read-byte io nil :eof))) (cond ((eq c :eof) (with-lock-held (lock) (setf buffer (nconc buffer (list :eof)))) (return)) ((= c 13)) ((= c +IAC+) (let ((c (read-byte io))) (cond ((= c +Interrupt-Process+) (process-interrupt process (lambda () (write-byte +IAC+ io) (write-byte +WILL+ io) (write-byte 6 io) (finish-output io) (break "Interrupted at #x4010D82E.")))) ((= c +DO+) (telnet-stream-process-option stream :do (read-byte io))) ((= c +DONT+) (telnet-stream-process-option stream :dont (read-byte io))) ((= c +WONT+) (telnet-stream-process-option stream :wont (read-byte io))) ((= c +WILL+) (telnet-stream-process-option stream :will (read-byte io))) ((= c +SB+) (let* ((option (read-byte io)) (verb (ecase (read-byte io) (0 :is) (1 :send))) (value (loop for x = (read-byte io) until (= x +IAC+) collect x))) (read-byte io) (telnet-stream-process-suboption stream option verb value) )) (t )))) (t (with-lock-held (lock) (setf buffer (nconc buffer (list (code-char c)))))) ))) (error () )))) (defmethod telnet-stream-process-option ((stream telnet-session-stream) verb option) ;;(format *dio* "~&;; Unprocessed TELNET option: ~S ~S.~%" verb option) ;;(finish-output *dio*) ) (defmethod telnet-stream-process-suboption ((stream telnet-session-stream) option verb value) ;;(format *dio* "~&;; Unprocessed TELNET suboption: ~S ~S ~S.~%" option verb value) ;;(finish-output *dio*) ) (defun start-top-level (fd top-level) (let* ((raw-stream (sys:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8))) (stream (make-instance 'telnet-session-stream :io raw-stream))) (setf (slot-value stream 'process) (make-process (lambda () (unwind-protect (let* ((*terminal-io* stream) (*standard-input* (make-synonym-stream '*terminal-io*)) (*standard-output* *standard-input*) (*error-output* *standard-input*) (*debug-io* *standard-input*) (*query-io* *standard-input*) (*trace-output* *standard-input*)) (funcall top-level)) (handler-case (progn (ignore-errors (close stream)) (close raw-stream)) (error ())))))) (telnet-session-io-loop stream) )) (defun default-top-level () (ext:print-herald) (mp::top-level)) (defun start-telnet-listener (&key (port 1025) (top-level #'default-top-level)) (labels (;; Turn an internet address into string format (ip-address-string (address) (format nil "~D.~D.~D.~D" (ldb (byte 8 24) address) (ldb (byte 8 16) address) (ldb (byte 8 8) address) (ldb (byte 8 0) address))) ;; The body of the connection listener. (listener (fd) (unwind-protect (loop ;; Wait for new connections. (mp::process-wait-until-fd-usable fd :input) (multiple-value-bind (new-fd remote-host) (ext:accept-tcp-connection fd) (let ((host-entry (ext:lookup-host-entry remote-host))) (make-process #'(lambda () (start-top-level new-fd top-level)) :name (format nil "Lisp session from ~A" (if host-entry (ext:host-entry-name host-entry) (ip-address-string remote-host))))))) ;; Close the listener stream. (when fd (unix:unix-close fd))))) ;; Pick a port (let ((fd nil)) (do () (fd) (handler-case (setf fd (ext:create-inet-listener port)) (error () (incf port)))) (prog1 (make-process (lambda () (listener fd)) :name (format nil "Lisp connection listener on port ~d" port)) (format t "~&;;; Started lisp connection listener on port ~d~%" port) (finish-output *standard-input*))))) #+CMU (defun debug::internal-debug () (let ((debug::*in-the-debugger* t) (debug::*read-suppress* nil)) (unless (typep debug::*debug-condition* 'debug::step-condition) ;;(clear-input debug::*debug-io*) (format debug::*debug-io* "~2&Debug (type H for help)~2%")) (debug::debug-loop)))