Commit a1e4c479 authored by james's avatar james
Browse files

*** empty log message ***

# CVS default ignores begin
# CVS default ignores end
;;;; ltelnetd.lisp -- Lisp Telnet daemon.
;;;; $Id: $
;;;; Copyfnord (K) 3170 James A. Crippen <>,
;;;; Martin Rydstrom <>
;;;; This software is in the Public Domain. If you break it you get to keep
;;;; both pieces.
;;;; ;;;;
;;;; NOTA BENE: This code doesn't work yet. It hasn't even been compiled. ;;;;
;;;; Don't expect it to do what you expect, or even what it expects. ;;;;
;;;; ;;;;
;;;; This is a Lisp Telnet daemon. To make it run, instantiate a TELNET-
;;;; LISTENER class with your favorite address and port (which default to
;;;;, ie the local network address, and port 23), then call START-
;;;; LISTENING on your new listener. To make it do something useful, stick a
;;;; function that accepts an IO stream into the HANDLER slot of the listener.
;;;; To stop listening call STOP-LISTENING (surprise surprise) on the
;;;; listener, which closes all connected sessions.
;;;; Much of the socket code has been stolen rather obviously from Araneida.
;;;; All the nonthreaded, non-SBCL stuff from Araneida has been taken out,
;;;; however. The TELNET-LISTENER class is a container that holds the various
;;;; info on the listener and the listener threads. The MASTER-THREAD slot
;;;; contains the thread which watches the listener threads and runs new ones
;;;; when they have quit. Threads are represented by the TELNET-THREAD
;;;; structure which is simply a handle containing the pid and some metadata
;;;; about the thread.
;;;; TODO:
;;;; - Finish Telnet stream implementation
;;;; - Q Method option negotiation (see RFC 1143)
;;;; - Telnet NVT support (Telnet characters, etc)
;;;; - Useful documentation (hah!)
;;;; - CL-TERMINFO linkage (eg, so server Terminfo can override Telnet chars)
;;;; - Telnet client?
#-sbcl (progn
(format t "LTELNETD does not run except with SBCL. Try porting it.")
(require #:sb-bsd-sockets)
(defpackage #:ltelnetd
(:use #:common-lisp #:sb-bsd-sockets)
(:export #:run-telnet-listener))
(in-package #:ltelnetd)
;;;;;; Classes.
;;; FIXME: Add :type to slots for optimizability.
(defclass telnet-listener ()
((handler :initform #'generic-telnet-handler :initarg :handler
:accessor telnet-listener-handler
:documentation "Function to run when connection is accepted.")
(overflow-handler :initform #'generic-telnet-overflow-handler
:initarg :overflow-handler
:accessor telnet-listener-overflow-handler
:documentation "Function to handle connections during overflow.")
(address :initform #(0 0 0 0) :initarg :address
:accessor telnet-listener-address
:documentation "Address on which to listen.")
(port :initform 23 :initarg :port :accessor telnet-listener-port
:documentation "Port on which to listen.")
(socket :initform nil :accessor telnet-listner-socket
:documentation "Socket of listener.")
(master-thread :initform nil :accessor telnet-listener-master-thread
:documentation "Master dispatching thread.")
(master-thread-sleep-time :initform 60
:accessor telnet-listener-master-thread-sleep-time
:documentation "Master thread sleep time.")
(max-spare :initform 5 :initarg :max-spare
:accessor telnet-listener-max-spare
:documentation "Maximum number of spare listening threads.")
(min-spare :initform 1 :initarg :min-spare
:accessor telnet-listener-min-spare
:documentation "Minimum number of spare listening threads.")
(threads :initform nil :accessor telnet-listener-threads
:documentation "Listening threads.")))
(defstruct telnet-thread
(quitting nil)
(state created :type (member created accepting connected finished dead nil)))
;;;;;; Utility Functions.
;;; Looks bugless, but should be kept synched with Dan's original version in
;;; Araneida. Or maybe obviated someday, though that's unlikely.
(defun forcibly-close-stream (s)
"Blow away the stream S no matter what it takes. Tries to do so nicely, then
becomes successively crueler, finally using SB-UNIX:UNIX-CLOSE on the offending
stream's file descriptor."
(let ((fd (sb-sys:fd-stream-fd s)))
(multiple-value-bind (r e) (ignore-errors (close s) t)
(unless r
(format t "Unable to close fd ~A: ~A, trying harder ~%" fd e)
(multiple-value-bind (r e) (ignore-errors (close s :abort t) t)
(unless r
(format t "still unable to close ~A: ~A, try harder ~%" fd e)
(multiple-value-bind (r e)
(ignore-errors (sb-unix:unix-close fd) t)
(unless r
(format t "Even unix-close failed on ~A:~A, giving up~%"
fd e)))))))))
;;;;;; Listeners.
(defun generic-telnet-handler (stream listener)
"This generic Telnet handler used if no other is supplied. Merely tells the
user that the daemon is running and accepting connections. Returns nothing."
(format stream "~&Welcome to LTELNETD, the Lisp Telnet Daemon.")
(format stream "~&You have connected to ~A on port ~A."
(telnet-listener-address listener)
(telnet-listener-port listener))
(format stream "~&There's nothing running here right now.")
(format stream "~&This has been the generic telnet listener.~%Bye.~%")
(defun generic-telnet-overflow-handler (stream listener)
"This generic overflow handler is used if no other is supplied. Tells the
user that no further connections are being accepted and closes the
connection. Returns nothing."
(format stream "~&You have connected to ~A on port ~A."
(telnet-listener-address listener)
(telnet-listener-port listener))
(format stream "~&No further connections are being accepted. Please try again later.")
(defmethod accept-connection ((listener telnet-listener) (thread telnet-thread))
"Puts the Telnet listener thread THREAD into a listening state, awaiting new
(setf (telnet-thread-state thread) 'accepting)
(flet ((accept (listener)
"Accepts a connection on LISTENER's socket, returns a stream of the connected socket."
(multiple-value-bind (socket peer port)
(socket-accept (telnet-listener-socket listener))
(socket-make-stream socket :element-type 'base-char
:input t :output t :buffering :none
:name (format nil "Telnet connection from ~A, port ~A"
peer port)))))
;; The ACCEPT below will block until a connection is made.
(let ((stream (accept listener)))
(setf (telnet-thread-state thread) 'connected)
(filter-telnet-session stream (telnet-listener-handler listener))
(setf (telnet-thread-state thread) 'finished)
(setf (telnet-thread-last-hit thread) (get-universal-time))
(forcibly-close-stream stream)))))
;;; FIXME: Question - Is there a reason that this isn't a method of TELNET-LISTENER?
(defun make-listener-thread (listener)
"Creates a Telnet listener thread."
(declare (type telnet-listener listener))
(let ((thread (make-telnet-thread)))
(setf (telnet-thread-pid thread)
(lambda ()
(loop (accept-connection listener thread)))))
(values thread)))
(defmethod cycle-master-thread ((listener telnet-listener))
(let ((min (telnet-listener-min-spare listener))
(max (telnet-listener-max-spare listener))
(spares 0))
;; Loop over all children and add new ones if necessary, or kill ones that
;; are stale. If there's nothing to do then sleep for a while.
(dolist (this-thread (telnet-listener-threads listener))
(when (numberp (telnet-thread-last-hit this-thread))
(cond ((not (zerop (sb-unix:unix-kill (telnet-thread-pid this-thread) 0)))
(format t "~&;; This thread (pid ~D) is dead~%"
(telnet-thread-pid this-thread))
(setf (telnet-thread-pid this-thread) 0))
((> max spares)
(format t "~&;; Thread ~A last used ~A, ~A spare~%"
(telnet-thread-pid this-thread)
(telnet-thread-last-hit this-thread)
(incf spares))
(t (format t "~&;; Thread ~A last used ~A, killing it~%"
(telnet-thread-pid this-thread)
(telnet-thread-last-used this-thread))
(sb-thread:terminate-thread (telnet-thread-pid this-thread))
(setf (telnet-thread-pid this-thread) 0)))))
;; Zero is a valid pid value but impossible for us to have.
(setf (telnet-listener-threads listener)
(remove-if #'zerop (telnet-listener-threads listener)
:key #'telnet-thread-pid))
(when (< spares min)
(dotimes (i (- min spares))
(format t "~&;; Count ~A spare threads < ~A, adding one more~%"
spares min)
(push (make-listener-thread (listener))
(telnet-listener-threads listener))))
(when (<= min spares max)
(sleep 60))
(sleep 1)))
(defmethod start-listening ((listener telnet-listener) &key (num-threads 5))
"Starts the Telnet daemon with the number of listener threads specified by
NUM-THREADS, defaulting to five. Returns the value of the MASTER-THREAD slot
(let ((socket (make-instance 'inet-socket :type :stream :protocol :tcp)))
(setf (sockopt-reuse-address socket) t)
(setf (sockopt-receive-buffer socket) 0)
(socket-bind socket (telnet-listener-address listener)
(telnet-listener-port listener))
(socket-listen socket 5)
(setf (telnet-listener-socket listener) socket)
(dotimes (i num-threads)
(push (make-listener-thread listener) (telnet-listener-threads listener)))
(setf (telnet-listener-master-thread listener)
(lambda ()
(loop (cycle-master-thread listener)))))))
(defmethod stop-listening ((listener telnet-listener) &key abort
"Stops the Telnet daemon and closes all open connections."
(declare (ignore abort)) ;FIXME: always aborting, fix this
(dolist (thread (telnet-listener-threads listener))
(when (zerop (sb-unix:unix-kill (telnet-thread-pid thread) 0))
(sb-thread:terminate-thread (telnet-thread-pid thread))))
(when (telnet-listener-master-thread listener)
(sb-thread:terminate-thread (telnet-listener-master-thread listener)))
(socket-close (telnet-listener-socket listener))
(setf (telnet-listener-threads listener) nil
(telnet-listener-master-thread listener) nil))
;;;;;; Telnet Stream
;;; FIXME: What should this class really inherit from? SB-SYS:FD-STREAM is a
;;; structure, and is internal, so should probably not be inherited. But it's
;;; what we use to create the stream from the socket. Is SB-SYS:FD-STREAM a
;;; FILE-STREAM? Or what? Perhaps we should just wrap up the socket->stream
;;; stuff and create a SOCKET-STREAM class for it to use.
;;; 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)
(command-mode :initform nil :type (member nil t)
:accessor stream-command-mode)
(got-iac :initform nil :type (member nil t)
:accessor stream-got-iac)
(remote-echo :initform t :type (member nil t)
:accessor stream-remote-echo)
(local-suppress-go-ahead :initform nil :type (member nil t)
:accessor 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)))
;;; The READ-CHAR and WRITE-CHAR functions are what users should use for I/O
;;; with a Telnet stream. They're supposed to transparently handle all Telnet
;;; commands discovered in the stream. To send Telnet commands to the client
;;; use the appropriate SEND-TELNET-COMMAND-* functions, not WRITE-CHAR.
(defmethod read-char ((stream telnet-stream))
(let ((char (if (stream-unread-chars stream)
(pop (stream-unread-chars stream))
(read-char stream))))
(case char
(+nvt-iac+ (setf (stream-got-iac stream) t)
(process-telnet-command stream))
(t char))))
(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)))))
;;;;;; Command Processing.
(defmethod process-telnet-option ((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 +NVT-IAC+ character. Returns STREAM."
(setf (stream-command-mode stream) t))
;;;;;; NVT Support.
;;; Telnet escape character.
(defconstant +nvt-iac+ (code-char 255))
;;; Option negotiation commands.
(defconstant +nvt-will+ (code-char 251))
(defconstant +nvt-wont+ (code-char 252))
(defconstant +nvt-do+ (code-char 253))
(defconstant +nvt-dont+ (code-char 254))
(defconstant +option-negotiation-list+
(list +nvt-will+ +nvt-wont+ +nvt-do+ +nvt-dont+))
;;; Commands.
(defconstant +nvt-se+ (code-char 240) "Subnegotiation End")
(defconstant +nvt-nop+ (code-char 241) "No-op")
(defconstant +nvt-dm+ (code-char 242) "Data Mark")
(defconstant +nvt-break+ (code-char 243) "Break")
(defconstant +nvt-ip+ (code-char 244) "Interrupt Process")
(defconstant +nvt-ao+ (code-char 245) "Abort Output")
(defconstant +nvt-ayt+ (code-char 246) "Are You There?")
(defconstant +nvt-ec+ (code-char 247) "Erase Character")
(defconstant +nvt-el+ (code-char 248) "Erase Line")
(defconstant +nvt-ga+ (code-char 249) "Go Ahead")
(defconstant +nvt-sb+ (code-char 250) "Subnegotiation Begin")
(defconstant +nvt-bell+ (code-char 7) "Bell")
;;; Options
(defconstant +nvt-echo+ (code-char 1))
(defconstant +nvt-supress-go-ahead+ (code-char 3))
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