;;; -*- Mode: LISP; Package: CHAOS -*- ;;; ;;; TO DO: ;;; ;;; (note: debugging in OpenMCL is easier after (require :cocoa) and File>New Listener) ;;; ;;; *** Missing functionality/features needed ;;; ;;; make receive-rfc populate pending-rfc's and fire off rfc-meets-lsn when ;;; matching listens happen ;;; check duplicate connection logic? ... not sure what this means anymore ;;; ;;; open-connection must put RFC on the send-pkts list to trigger ;;; retransmission ;;; ;;; accept/transmit-opn must put the OPN on the send-pkts list to trigger ;;; retransmission. ;;; ;;; actual OPN transactions (full connections established..) - this is partly done ;;; (see above for missing parts) ;;; flow control -- partially complete, but get-next-pkt does not ;;; check/update window status ;;; server processes? ;;; FILE server process ;;; ;;; *** Redesign possibilities ;;; ;;; Encapsulation into a NCP object, which would contain all the ;;; processes and socket machinery necessary to support the equivalent of a single ;;; "host" on the Chaosnet ;;; ;;; I am thinking of breaking the file up. Major sections include ;;; ;;; 1. Communication with the user-mode sockets (i.e. the medium) ;;; 2. Decoding of packet contents according to Chaos standard ;;; 3. Perhaps the locking primitives (or I should add them to bordeaux-threads) ;;; 4. Connection-level declarations and primitives ;;; 5. NCP behavior, including retransmission ;;; 6. Any higher level protocols. ;;; ;;; *** Possible Improvements ;;; ;;; Make a nice set of conditions, instead of returning an assortment ;;; of raised errors, symbols and strings. ;;; ;;; conditionalize and/or clean up debugging verbosity ;;; ;;; Support of TCP/IP sockets in addition to UNIX-domain sockets ;;; ;;; Better printing of objects, listing routines, other ;;; debugging and status reporting tools ;;; ;;; better detection of bad packets ;;; (wrong endinaness of software byte count from time.c, e.g.) ;;; ;;; more semaphore signalling in place of process-wait semantics? ;;; e.g. as LISTEN waits for matching RFC or vice-versa, the incoming packet ;;; semaphore could be used to signal ;;; ;;; *** Things done already (?) ;;; ;;; *PROPER BLOCKING FOR GET-NEXT-PKT* ;;; this is about using a semaphore rather than a simple lock on the ;;; read packets list. ;;; --this might be done now ;;; ;;; I think the ACK numbering of OPN/STS packets is not following what ;;; CADR does. Try to get an example that works on CADR alone, talking ;;; to itself, and see what goes over the wire. ;;; -- I think this is an arbitrary choice of how OPN packets number themselves. ;;; ;;; chaos:simple ;;; chaos:reject ;;; ;;; *** Low priority stuff ;;; ;;; fix (setf status-node-name) to not mess up other bits of a status ;;; packet; low priority, because worked around. ;;; ;;; ;;; openmcl-chaos.lisp ;;; ;;; Code for OpenMCL to work with the user-mode ChaosNET emulation ;;; ;;; ;;; $Revision: 1.11 $ ;;; ;;; $Log: openmcl-chaos.lisp,v $ ;;; Revision 1.11 2006/09/09 17:45:57 jao ;;; 1. Lisp machine character conversions (crude: no escaping conventions) ;;; 2. Some basic mail service routines. (will partition into a new file) ;;; ;;; Revision 1.10 2006/08/01 00:11:02 jao ;;; 1. Coded byte-stream functionality ;;; 2. Changed to use a semaphore to signal window availability on transmit. ;;; 3. Other changes to locking w.r.t. connection slots. ;;; I believe this squashed the previous deadlock bug; possibly replaced ;;; it with new ones, more deeply buried. ;;; 3. Coded a crude hostat function ;;; 4. (In commented section) receive-qsend ;;; ;;; Revision 1.9 2006/07/27 01:38:38 jao ;;; 1. implemented receive-los, reject ;;; 2. Fixed up listen ;;; 3. Deprecate data-available ;;; 4. Cleaned up and enlarged TODO section. ;;; ;;; Revision 1.8 2006/07/19 01:49:30 jao ;;; 1. Added retransmission logic ;;; 2. Implemented receive-cls ;;; 3. First attempt at semaphore-using get-next-pkt ;;; ;;; Revision 1.7 2006/05/08 02:15:12 jao ;;; 1. Added much of the windowing logic, although the packet numbers ;;; and handshakes seem not to work right with CADR ;;; 2. added chaos:accept, chaos:connect, chaos:may-transmit ;;; ;;; Revision 1.6 2006/04/09 22:58:08 jao ;;; 1. changed make-status-ans-packet to make valid packets. still a small bug ;;; somewhere in (setf status-node-name) ;;; 2. Added enough functionality to support CHAOS:SIMPLE ;;; 3. Added several support routines for flow-control, but not yet complete ;;; 4. Refactored slightly to put address labelling in transmit-pkt. ;;; Probably a lot of other things could be cleaner, but seems OK for now. ;;; ;;; Revision 1.5 2006/04/08 16:46:37 jao ;;; 1. Enforce sending of integral number of 16-bit words on the ether, ;;; to match with usim expectations (and Lisp machine hardware?) ;;; 2. Add locks for *chaos-socket* ;;; 3. Remove optional arguments allowing flexible choice of *chaos-socket* ;;; Will have to wait until there can be per-socket locks, probably by ;;; making a "transceiver object" which contains all these in one package. ;;; 4. Added enough handling of incoming RFC's to allow LISTEN to work. ;;; 5. Listed some basic TODO's ;;; ;;; Revision 1.4 2006/04/01 03:52:53 jao ;;; Many changes. First version that seems to do all right responding to a ;;; RFC for STATUS. Still could be much improved in design, and still needs ;;; much functionality. ;;; ;;; Revision 1.3 2006/02/12 01:44:20 jao ;;; Fixed missing arguments on several calls, byte-count errors. ;;; ;;; Revision 1.2 2006/02/12 00:49:59 jao ;;; Code cleanup, added print-object method. ;;; ;;; Revision 1.1 2006/02/04 22:46:22 jao ;;; Initial revision ;;; ;;; ;;; ;;; notes: changing the endianness of the hw address mostly seems to work ;;; but seems to trigger serious packet storms with usim in simple transactions. ;;; e.g. try (hostat 401), and a huge stream of packets bursts out where ;;; a simple RFC, ANS pair should occur. ;;; ;;; Don't remember this behavior before. ;;; part of it is that usim seems to echo back packets it receives to ;;; the chaosd. ;;; ;;; Resolved: 30 Mar 2006: seems to be due to chaosd's server process ;;; forwarding all packets not addressed to or from it back to the same ether ;;; from which it came, repeatedly until the forwarding count maxes out. ;;; The difference was that there was a new source (this program) on the ;;; ether that created just such packets, and caused other such packets to ;;; be createdin response. ;;; ;;; enforce sending only even number of 8-bit bytes (i.e., integral ;;; number of 16-bit words.) Not 100% clear how physical ChaosNETs ;;; handle this, but I think the LispM hardware might only send ;;; 16-bit words, and in any case, it confuses usim's code to handle ;;; this case. (hw dest addr crosses word boundaries, and is scrambled ;;; by byte-swapping. Could pad the data section on reading from the "ether" ;;; as well as enforcing it here.) (defpackage "CHAOS" (:use :common-lisp :lispm.char) (:shadow "CLOSE" "LISTEN" "STREAM" "FORCE-OUTPUT") (:export "*CHAOS-SOCKET*" "*CHAOS-ADDRESS*" ; "CONNECT-TO-SERVER" "START-CHAOS" "PACKET" "CONNECTION" "ADDRESS" "OPCODE" "+RFC-OP+" "+OPN-OP+" "+CLS-OP+" "+FWD-OP+" "+ANS-OP+" "+SNS-OP+" "+STS-OP+" "+RUT-OP+" "+LOS-OP+" "+LSN-OP+" "+MNT-OP+" "+EOF-OP+" "+UNC-OP+" "+DAT-OP+" "CONNECTION-INDEX" "SHORT-ADDRESS" "CLOSE" "LISTEN" "CONNECT" "ACCEPT" "SIMPLE" "REJECT" "SEND-STRING" "STATE" "GET-NEXT-PKT" "VALID-DATA-BYTES" "DATA-STRING" ;"DATA-AVAILABLE" "STREAM" "EOF" "INPUT-BYTE" "FINISH" "CLEAR-EOF" "SEND-EOF" "OUTPUT-BYTE" "FORCE-OUTPUT" "CREATE-STREAM" "READ-LM-LINE" "READ-TO-EOF" "WRITE-LM-LINE" )) (in-package "CHAOS") (defconstant +CHAOS-ETHER-SOCKET+ "/var/tmp/chaosd_server") (defvar *CHAOS-SOCKET* nil) (defparameter *chaos-socket-write-lock* (ccl::make-lock)) (defparameter *chaos-socket-read-lock* (ccl::make-lock)) (defparameter *CHAOS-ADDRESS-SHORT* #o402) (defparameter *CHAOS-HOST-NAME* "openmcl") (defun client-socket-address () (format nil "/var/tmp/chaosd_~5,'0D" (ccl::getpid))) (defun connect-to-server () ;; should I make this silently reuse *chaos-socket*? ;; in some cases, like a chaosd rejection of a packet, the ;; *chaos-socket* could be closed; if *chaos-socket* is OK ;; perhaps we should just not reconnect, but it is probably ;; harmless to close and re-open (when *chaos-socket* (ignore-errors (close *chaos-socket*))) ;; this unix-addr is what the C version does, but ;; perhaps I should use a temporary file or whatever ;; it is that must be unique, and does not persist ;; if the program exits abnormally ;; also, perhaps I will need more than one for this ;; process? (let ((unix-addr (client-socket-address)) (my-socket-fd (ccl::socket-call nil "socket" (ccl::c_socket #$PF_LOCAL #$SOCK_STREAM 0)))) (when (probe-file unix-addr) (delete-file unix-addr)) (ccl::bind-unix-socket my-socket-fd unix-addr) (ccl::file-socket-connect my-socket-fd +CHAOS-ETHER-SOCKET+) (setf *chaos-socket* (ccl::make-file-socket-stream my-socket-fd :format :binary :class 'ccl::file-socket-stream) *chaos-socket-write-lock* (ccl::make-lock) *chaos-socket-read-lock* (ccl::make-lock)) *chaos-socket*)) (defclass address () ((subnet :accessor subnet :initarg :subnet) (host :accessor host :initarg :host))) (defclass connection-index () ((table-index :accessor table-index :initarg :table-index) (uniqizer :accessor uniqizer :initarg :uniqizer))) (defun index-to-short (table-index uniqizer) (+ table-index (* 256 uniqizer))) (defun address-to-short (subnet host) (+ host (* 256 subnet))) (defmethod print-object ((addr address) stream) (print-unreadable-object (addr stream :type t :identity t) (format stream "#o~o :subnet ~D :host ~D" (address-short addr) (subnet addr) (host addr)))) (defmethod address-short ((addr address)) (address-to-short (subnet addr) (host addr))) (defmethod index-short ((index connection-index)) (index-to-short (table-index index) (uniqizer index))) (defmethod short-address ((short integer)) (make-instance 'address :subnet (ldb (byte 8 8) short) :host (ldb (byte 8 0) short))) (defmethod short-index ((short integer)) (make-instance 'connection-index :table-index (ldb (byte 8 0) short) :uniqizer (ldb (byte 8 8) short))) (defmethod address-= ((addr1 address) (addr2 address)) (and (= (subnet addr1) (subnet addr2)) (= (host addr1) (host addr2)))) (defmethod address-= ((addr1 address) (addr2 integer)) (= (address-short addr1) addr2)) (defmethod address-= ((addr1 integer) (addr2 address)) (= addr1 (address-short addr2))) (defmethod address-= ((addr1 integer) (addr2 integer)) (= addr1 addr2)) (defmethod print-object ((index connection-index) stream) (print-unreadable-object (index stream :type t :identity t) (format stream "#x~x :table-index ~D :uniqizer ~D" (index-short index) (table-index index) (uniqizer index)))) (defmethod index-= ((idx1 connection-index) (idx2 connection-index)) (and (= (table-index idx1) (table-index idx2)) (= (uniqizer idx1) (uniqizer idx2)))) (defmethod index-= ((idx1 connection-index) (idx2 integer)) (= (index-short idx1) idx2)) (defmethod index-= ((idx1 integer) (idx2 connection-index)) (= idx1 (index-short idx2))) (defmethod index-= ((idx1 integer) (idx2 integer)) (= idx1 idx2)) (defparameter *chaos-address* (short-address *chaos-address-short*)) (defun packet-len-fc-to-short (packet-len fwd-count) (+ packet-len (* #x1000 fwd-count))) (defconstant +max-packet-data+ (/ 4032 8) "Maximum number of data bytes, excluding the hardware header and the user-mode header bytes") (defconstant +hw-header-bytes+ (* 2 3) "Number of bytes associated with the hardware header: source transceiver address, destination transceiver address, and checksum, each 16 bits long.") (defconstant +sw-header-bytes+ (* 2 8) "Number of bytes associated with the software header: opcode, byte count, logical source & destination addresses + indexes, packet and acknowledgement numbers.") (defconstant +user-mode-header-bytes+ 4 "Number of header bytes associated with the UNIX-domain socket interface") (defconstant +max-data-byte-count+ 488 "Maximum data byte count allowed in the payload, not counting the user-mode, hardware, or software header bytes.") (defconstant +total-bytes+ (+ +max-packet-data+ +hw-header-bytes+ +user-mode-header-bytes+)) (defclass packet () ((byte-array :type '(array (+total-bytes+) (unsigned-byte 8)) :initform (make-array +total-bytes+ :element-type '(unsigned-byte 8) :initial-element 0) :accessor byte-array))) (defmethod raw-data-bytes ((pkt packet)) "Returns a displaced array referring to the software-visible data-bytes of the Chaos packet. I.e. it does not show either the Unix socket header or the hardware address or checksum, but does include the software-level header." (make-array +max-packet-data+ :displaced-to (byte-array pkt) :displaced-index-offset +user-mode-header-bytes+ :element-type '(unsigned-byte 8))) ; perhaps these displaced-arrays should be generated when ; the packet is initialized, and stored in slots ; ...but only if they are ever really used... (defmethod data-bytes ((pkt packet)) (make-array (- +max-packet-data+ +sw-header-bytes+) :displaced-to (byte-array pkt) :displaced-index-offset (+ +user-mode-header-bytes+ +sw-header-bytes+) :element-type '(unsigned-byte 8))) (defmethod valid-data-bytes ((pkt packet)) (make-array (data-byte-count pkt) :displaced-to (data-bytes pkt))) (defmethod data-string ((pkt packet)) (let* ((count (data-byte-count pkt)) (data (valid-data-bytes pkt)) (str (make-string count))) (dotimes (i count str) (setf (aref str i) (code-char (aref data i)))))) ;;; define accessors for bytes within the packet ;;; (defmethod packet-byte ((pkt packet) byte-offset) (aref (byte-array pkt) (+ +user-mode-header-bytes+ byte-offset))) (defmethod (setf packet-byte) (value (pkt packet) byte-offset) (setf (aref (byte-array pkt) (+ +user-mode-header-bytes+ byte-offset)) value)) (defmethod data-byte ((pkt packet) data-offset) (aref (byte-array pkt) (+ +user-mode-header-bytes+ +sw-header-bytes+ data-offset))) (defmethod (setf data-byte) (value (pkt packet) data-offset) (setf (aref (byte-array pkt) (+ +user-mode-header-bytes+ +sw-header-bytes+ data-offset)) value)) (defmethod packet-byte-pair ((pkt packet) byte-offset) "Return two values: conventionally the LSB and MSB of a 16-bit word" (values (packet-byte pkt byte-offset) (packet-byte pkt (+ 1 byte-offset)))) (defmethod set-packet-byte-pair ((pkt packet) byte-offset lsb msb) (setf (packet-byte pkt byte-offset) lsb (packet-byte pkt (+ 1 byte-offset)) msb)) (defmethod packet-word ((pkt packet) byte-offset) (multiple-value-bind (lsb msb) (packet-byte-pair pkt byte-offset) (+ lsb (* 256 msb)))) (defmethod (setf packet-word) (value (pkt packet) byte-offset) (set-packet-byte-pair pkt byte-offset (ldb (byte 8 0) value) (ldb (byte 8 8) value)) value) (defmacro define-packet-byte (accessor-symbol byte-array-offset &optional documentation-string) (let ((ba-offset (gensym))) `(let ((,ba-offset ,byte-array-offset)) (defmethod ,accessor-symbol ((pkt packet)) ,documentation-string (packet-byte pkt ,ba-offset)) (defmethod (setf ,accessor-symbol) (value (pkt packet)) ,documentation-string (setf (packet-byte pkt ,ba-offset) value))))) (defmacro define-packet-word (accessor-symbol byte-array-offset &optional documentation-string) "Define setf'able accessor for the 16-bit word (LSB first) at the indicated offset in the raw byte-array." (let ((ba-offset (gensym))) `(let ((,ba-offset ,byte-array-offset)) (defmethod ,accessor-symbol ((pkt packet)) ,documentation-string (packet-word pkt ,ba-offset)) (defmethod (setf ,accessor-symbol) (value (pkt packet)) ,documentation-string (setf (packet-word pkt ,ba-offset) value))))) #| ;;; oops, the user-mode byte count is MSB first... (define-packet-word user-mode-byte-count (- +user-mode-header-bytes+) "Accessor for byte count for the user-mode socket interface; count of software & header bytes (i.e. hw-data-byte-count), does not include user-mode header bytes. Used to determine the size of the socket read necessary to receive the full packet after the header has been read.") |# (defmethod user-mode-byte-count ((pkt packet)) "Count of software and header bytes, not including the actual user mode header bytes. Used to determine the size of the socket read/write necessary to receive/send the full packet *after* the user mode header has been read. BIG ENDIAN: MSB first" (multiple-value-bind (msb lsb) (packet-byte-pair pkt (- +user-mode-header-bytes+)) (+ lsb (* 256 msb)))) (defmethod (setf user-mode-byte-count) (value (pkt packet)) "Count of software and header bytes, not including the actual user mode header bytes. Used to determine the size of the socket read/write necessary to receive/send the full packet *after* the user mode header has been read. ENFORCES integer number of 16-bit words." (let ((actual-value (* 2 (ceiling value 2)))) (set-packet-byte-pair pkt (- +user-mode-header-bytes+) (ldb (byte 8 8) actual-value) (ldb (byte 8 0) actual-value)) actual-value)) (define-packet-byte protocol-type 0 "Chaos protocol type, define as zero in AI Memo 628.") (define-packet-byte opcode 1 "Chaos opcode field") (defconstant +rfc-op+ 1 "RFC") (defconstant +opn-op+ 2 "OPN") (defconstant +cls-op+ 3 "CLS") (defconstant +fwd-op+ 4 "FWD") (defconstant +ans-op+ 5 "ANS") (defconstant +sns-op+ 6 "SNS") (defconstant +sts-op+ 7 "STS") (defconstant +rut-op+ #o10 "RUT") (defconstant +los-op+ #o11 "LOS") (defconstant +lsn-op+ #o12 "LSN") (defconstant +mnt-op+ #o13 "MNT") (defconstant +eof-op+ #o14 "EOF") (defconstant +unc-op+ #o15 "UNC") (defconstant +dat-op+ #o200 "DAT") (define-packet-word packet-number 12 "Identifying number for a controlled packet.") (define-packet-word ack-number 14 "Indicates all controlled packets up to and including this packet-number have been successfully received.") #| (defmethod protocol-type ((pkt packet)) (aref (byte-array pkt) +user-mode-header-bytes+)) (defmethod (setf protocol-type) (value (pkt packet)) (setf (aref (byte-array pkt) +user-mode-header-bytes+) value)) (defmethod opcode ((pkt packet)) (aref (byte-array pkt) (+ +user-mode-header-bytes+ 1))) (defmethod (setf opcode) (value (pkt packet)) (setf (aref (byte-array pkt) (+ +user-mode-header-bytes+ 1)) value)) |# (defmethod data-byte-count ((pkt packet)) (multiple-value-bind (lsb msb) (packet-byte-pair pkt 2) (+ lsb (* 256 (ldb (byte 4 0) msb))))) (defmethod sw-data-byte-count ((pkt packet)) (+ (data-byte-count pkt) +sw-header-bytes+)) (defmethod hw-data-byte-count ((pkt packet)) (let ((8-bit-bytes (+ (sw-data-byte-count pkt) +hw-header-bytes+))) (* 2 (ceiling 8-bit-bytes 2)))) (defmethod total-byte-count ((pkt packet)) (+ (hw-data-byte-count pkt) +user-mode-header-bytes+)) (defmethod (setf data-byte-count) (value (pkt packet)) "Set the data payload length in bytes; this count includes even the software header. Also updates the user-mode transport byte count." (unless (and (integerp value) (<= 0 value +max-data-byte-count+)) (error "Illegal Chaos packet byte count")) (setf (packet-byte pkt 2) (ldb (byte 8 0) value) (ldb (byte 4 0) (packet-byte pkt 3)) (ldb (byte 4 8) value)) (setf (user-mode-byte-count pkt) ; will be even number of 8-bit bytes (+ +hw-header-bytes+ +sw-header-bytes+ value)) value) #| (defmethod (setf user-mode-byte-count) (value (pkt packet)) "Set byte count for the user-mode socket interface; count of software & header bytes (i.e. hw-data-byte-count); does not include user-mode header. BIG ENDIAN: i.e. MSB first" (let ((ba (byte-array pkt))) (setf (aref ba 0) (ldb (byte 8 8) value) (aref ba 1) (ldb (byte 8 0) value))) value) (defmethod (setf data-byte-count) (value (pkt packet)) "Set the data payload length in bytes; this count does not include the software header. Also updates the user-mode transport byte count." (unless (and (integerp value) (<= 0 value +max-data-byte-count+)) (error "Illegal Chaos packet byte count")) (let ((ba (byte-array pkt))) (setf (aref ba (+ +user-mode-header-bytes+ 2)) (ldb (byte 8 0) value) (ldb (byte 4 0) (aref ba (+ +user-mode-header-bytes+ 3))) (ldb (byte 4 8) value)) (setf (user-mode-byte-count pkt) (hw-data-byte-count pkt))) value) |# (defmethod forwarding-count ((pkt packet)) (ldb (byte 4 4) (packet-byte pkt 3))) (defmethod (setf forwarding-count) (value (pkt packet)) (unless (and (integerp value) (<= 0 value 15)) (error "Illegal packet forwarding count")) (setf (ldb (byte 4 4) (packet-byte pkt 3)) value)) (defmethod sw-dest-address ((pkt packet)) (multiple-value-bind (h s) (packet-byte-pair pkt 4) (make-instance 'address :host h :subnet s))) (defmethod (setf sw-dest-address) ((addr address) (pkt packet)) (with-accessors ((n subnet) (h host)) addr (set-packet-byte-pair pkt 4 h n)) addr) (defmethod sw-source-address ((pkt packet)) (multiple-value-bind (h s) (packet-byte-pair pkt 8) (make-instance 'address :host h :subnet s))) (defmethod (setf sw-source-address) ((addr address) (pkt packet)) (with-accessors ((n subnet) (h host)) addr (set-packet-byte-pair pkt 8 h n)) addr) (defmethod (setf sw-source-address) ((short integer) (pkt packet)) (let ((addr (short-address short))) (setf (sw-source-address pkt) addr))) (defmethod (setf sw-dest-address) ((short integer) (pkt packet)) (let ((addr (short-address short))) (setf (sw-dest-address pkt) addr))) (defmethod dest-index ((pkt packet)) (multiple-value-bind (ti uniq) (packet-byte-pair pkt 6) (make-instance 'connection-index :table-index ti :uniqizer uniq))) (defmethod source-index ((pkt packet)) (multiple-value-bind (ti uniq) (packet-byte-pair pkt 10) (make-instance 'connection-index :table-index ti :uniqizer uniq))) (defmethod (setf dest-index) ((index connection-index) (pkt packet)) (with-accessors ((ti table-index) (uniq uniqizer)) index (set-packet-byte-pair pkt 6 ti uniq)) index) (defmethod (setf source-index) ((index connection-index) (pkt packet)) (with-accessors ((ti table-index) (uniq uniqizer)) index (set-packet-byte-pair pkt 10 ti uniq)) index) (defmethod (setf source-index) ((short integer) (pkt packet)) (let ((index (short-index short))) (setf (source-index pkt) index))) (defmethod (setf dest-index) ((short integer) (pkt packet)) (let ((index (short-index short))) (setf (dest-index pkt) index))) ;; words at byte offset 12, 14 ;; are defined above for packet number ;; and acknowledge number ;; hardware addresses and checksum occur at the end of the ;; data area ;; ;; in the original Chaos implementation, the destination word is ;; loaded just as the software addresses are; the source word ;; and checksum are added by the hardware (it seems) ;; ;; The user-mode code (and CADR simulator) must avoid endian-ness ;; issues here. ;; ;; NOTE ALSO: the hardware data byte count is rounded up to be ;; an integer number of 16-bit words; the software byte count ;; may be an odd number of 8-bit words. Properly written software ;; should not depend on the value of the "extra" byte. ;; The hardware addresses & checksum should occur on 16-bit boundaries. ;; ;; It is not clear from sources available to me whether this was ;; enforced by all ChaosNET hardware implementations, but it seems ;; it might have been by the Lisp Machine interface. ;; (defmethod hw-source-address ((pkt packet)) (when (zerop (user-mode-byte-count pkt)) (error "HW Addressing requires a valid byte count")) (multiple-value-bind (h s) ;;; NOTE ENDIAN FIX in server.c (packet-byte-pair pkt (- (hw-data-byte-count pkt) 4)) (make-instance 'address :host h :subnet s))) (defmethod (setf hw-source-address) ((addr address) (pkt packet)) (with-accessors ((n subnet) (h host)) addr (set-packet-byte-pair pkt (- (hw-data-byte-count pkt) 4) h n) addr)) (defmethod (setf hw-source-address) ((short integer) (pkt packet)) (let ((addr (short-address short))) (setf (hw-source-address pkt) addr))) (defmethod hw-dest-address ((pkt packet)) (when (zerop (user-mode-byte-count pkt)) (error "HW Addressing requires a valid byte count")) (multiple-value-bind (h s) ;;; NOTE ENDIAN FIX in server.c (packet-byte-pair pkt (- (hw-data-byte-count pkt) 6)) (make-instance 'address :host h :subnet s))) (defmethod (setf hw-dest-address) ((addr address) (pkt packet)) (with-accessors ((n subnet) (h host)) addr (set-packet-byte-pair pkt (- (hw-data-byte-count pkt) 6) h n) addr)) (defmethod (setf hw-dest-address) ((short integer) (pkt packet)) (let ((addr (short-address short))) (setf (hw-dest-address pkt) addr))) (defmethod hw-checksum ((pkt packet)) (when (zerop (user-mode-byte-count pkt)) (error "HW Addressing requires a valid byte count")) (packet-word pkt (- (hw-data-byte-count pkt) 2))) (defmethod (setf hw-checksum) (value (pkt packet)) (when (zerop (user-mode-byte-count pkt)) (error "HW Addressing requires a valid byte count")) (setf (packet-word pkt (- (hw-data-byte-count pkt) 2)) value)) (defmethod set-pkt-string ((pkt packet) &rest strings) (let* ((str (apply #'concatenate 'string strings)) (len (length str))) (dotimes (i len) (setf (data-byte pkt i) (char-code (aref str i)))) (setf (data-byte-count pkt) len) pkt)) (defun read-packet () ;; &optional (chaos-socket *CHAOS-SOCKET*)) ;; not until there is a way to match up multiple sockets ;; with the corresponding locks... (let ((pkt (make-instance 'packet)) (chaos-socket *chaos-socket*)) (ccl::with-lock-grabbed (*chaos-socket-read-lock*) (dotimes (i +user-mode-header-bytes+) (setf (aref (byte-array pkt) i) (read-byte chaos-socket))) (dotimes (i (user-mode-byte-count pkt) pkt) (setf (packet-byte pkt i) (read-byte chaos-socket)))))) (defmethod write-packet ((pkt packet)) ;; &optional (chaos-socket *CHAOS-SOCKET*)) ;; not until I can match sockets to corresponding locks (when (zerop (user-mode-byte-count pkt)) (error "Invalid byte count")) (let ((chaos-socket *chaos-socket*)) (ccl:with-lock-grabbed (*chaos-socket-write-lock*) (dotimes (i (total-byte-count pkt)) (write-byte (aref (byte-array pkt) i) chaos-socket)) (ccl:stream-force-output chaos-socket) (incf *packets-transmitted*)))) (defun write-chaos-packet (opcode data hw-dest-addr sw-dest-addr dest-index source-index packet-number acknowledge-number &key ;; (chaos-socket *CHAOS-SOCKET*) (fwd-count 0) (protocol-type 0) (hw-source-addr *CHAOS-ADDRESS*) (sw-source-addr hw-source-addr)) (let* ((data-len (length data)) (pkt (make-instance 'packet))) ;;; ChaosNET software packet header (setf (protocol-type pkt) protocol-type (opcode pkt) opcode (data-byte-count pkt) data-len (forwarding-count pkt) fwd-count (sw-dest-address pkt) sw-dest-addr (dest-index pkt) dest-index (sw-source-address pkt) sw-source-addr (source-index pkt) source-index (packet-number pkt) packet-number (ack-number pkt) acknowledge-number) ;;; actual data (ctypecase data (string (dotimes (i data-len) (setf (data-byte pkt i) (char-code (aref data i))))) (vector (dotimes (i data-len) (setf (data-byte pkt i) (aref data i))))) (setf (hw-dest-address pkt) hw-dest-addr (hw-source-address pkt) hw-source-addr) (let ((checksum 0)) (setf (hw-checksum pkt) checksum)) (write-packet pkt) ;; chaos-socket) pkt)) #| (chaos::connect-to-server) ;;; # (setf *sentpkt* (chaos::write-chaos-packet 1 "STATUS" #o404 #o404 #o0 99 0 0)) ;;; # (setf *ownpkt* (chaos::read-packet)) ;;; # (setf *anspkt* (chaos::read-packet)) ;;; # (chaos::sw-dest-address *anspkt*) ;;;#
(chaos::dest-index *anspkt*) ;;;# (chaos::data-byte-count *anspkt*) ;;; 68 |# #| ;; deprecated: make a packet and use write-packet (defun write-chaos-string (str &optional (chaos-socket *chaos-socket*)) (let ((l (length str))) (ccl:stream-write-byte chaos-socket (ldb (byte 8 8) l)) (ccl:stream-write-byte chaos-socket (ldb (byte 8 0) l)) (ccl:stream-write-byte chaos-socket 0) (ccl:stream-write-byte chaos-socket 0) (dotimes (i l) (ccl:stream-write-byte chaos-socket (char-code (aref str i)))) (ccl:stream-force-output chaos-socket))) (defun read-chaos-string (&optional (chaos-socket *chaos-socket*)) (let ((header (make-array 4 :element-type 'unsigned-byte))) (dotimes (i 4) (setf (aref header i) (read-byte chaos-socket))) (let* ((len (+ (aref header 1) (* 256 (aref header 0)))) (result (make-string len))) (dotimes (i len result) (setf (aref result i) (code-char (read-byte chaos-socket))))))) |# ;;; ANS to STATUS packet ;;; (defconstant +status-name-length+ 32) (defmethod status-node-name ((pkt packet)) (let* ((zero-offset (min +status-name-length+ (position 0 (data-bytes pkt)))) (name (make-string zero-offset))) (dotimes (i zero-offset name) (setf (aref name i) (code-char (data-byte pkt i)))))) (defmethod (setf status-node-name) (name (pkt packet)) (dotimes (i (length name)) (setf (data-byte pkt i) (char-code (aref name i)))) (dotimes (i (- +status-name-length+ (length name))) (setf (aref (data-bytes pkt) (- +status-name-length+ (- i 1))) 0)) name) (define-packet-word status-subnet-word (+ +sw-header-bytes+ +status-name-length+) "#o400 plus a subnet number") (defmethod status-subnet ((pkt packet)) (- (status-subnet-word pkt) #o400)) (defmethod (setf status-subnet) (subnet (pkt packet)) (setf (status-subnet-word pkt) (+ #o400 subnet))) (define-packet-word status-word-count (+ 2 +sw-header-bytes+ +status-name-length+) "count of 16 bit words to follow, usually 16") (defmethod packet-32-word ((pkt packet) byte-offset) (+ (* 65536 (packet-word pkt (+ byte-offset 2))) (packet-word pkt byte-offset))) (defmethod (setf packet-32-word) (value (pkt packet) byte-offset) (setf (packet-word pkt byte-offset) (ldb (byte 16 0) value) (packet-word pkt (+ 2 byte-offset)) (ldb (byte 16 16) value))) (defmacro define-packet-32-word (accessor-symbol byte-array-offset &optional documentation-string) "Define setf'able accessor for the 16-bit word (LSB first) at the indicated offset in the raw byte-array." (let ((ba-offset (gensym))) `(let ((,ba-offset ,byte-array-offset)) (defmethod ,accessor-symbol ((pkt packet)) ,documentation-string (packet-32-word pkt ,ba-offset)) (defmethod (setf ,accessor-symbol) (value (pkt packet)) ,documentation-string (setf (packet-32-word pkt ,ba-offset) value))))) (define-packet-32-word status-packets-received (+ 4 +sw-header-bytes+ +status-name-length+)) ; 36 (define-packet-32-word status-packets-transmitted (+ 8 +sw-header-bytes+ +status-name-length+)) ; 40 (define-packet-32-word status-tx-aborts (+ 12 +sw-header-bytes+ +status-name-length+)) ; 44 (define-packet-32-word status-rx-dropped (+ 16 +sw-header-bytes+ +status-name-length+)) ; 48 (define-packet-32-word status-rx-crc-errors (+ 20 +sw-header-bytes+ +status-name-length+)) ; 52 (define-packet-32-word status-rx-read-errors (+ 24 +sw-header-bytes+ +status-name-length+)) ; 56 (define-packet-32-word status-rx-length-errors (+ 28 +sw-header-bytes+ +status-name-length+)) ; 60 (define-packet-32-word status-rx-other-errors (+ 32 +sw-header-bytes+ +status-name-length+)) ; 64 (defun make-status-ans-packet () (let ((pkt (make-instance 'packet))) (setf (opcode pkt) +ans-op+ ;; set the addresses at a higher level: ;; the response function should fill in the ;; proper destination & sources? ; (sw-source-address pkt) *chaos-address* ; (hw-source-address pkt) *chaos-address* ; (hw-dest-address pkt) dest-address ; (sw-dest-address pkt) dest-address ; (dest-index pkt) dest-index ; (src-index pkt) (short-index 0) ; (packet-number pkt) 0 ; (ack-number pkt) 0 (data-byte-count pkt) (+ 4 (* 2 16) +status-name-length+) (status-node-name pkt) *chaos-host-name* ; was tromping on other fields? (status-subnet pkt) (subnet *chaos-address*) (status-word-count pkt) 16 (status-packets-received pkt) *packets-received* (status-packets-transmitted pkt) *packets-transmitted* (status-tx-aborts pkt) *tx-aborts* (status-rx-dropped pkt) *rx-dropped* (status-rx-crc-errors pkt) *rx-crc-errors* (status-rx-read-errors pkt) *rx-read-errors* (status-rx-length-errors pkt) *rx-length-errors* (status-rx-other-errors pkt) *rx-other-errors*) pkt)) (defmethod hostat ((addr integer)) (hostat (chaos:short-address addr))) (defmethod hostat ((addr address)) "Perform a STATUS inquiry to the specifed ADDR." (let ((result (chaos:simple addr "STATUS" 60))) (when (stringp result) (error "HOSTAT: ~S" result)) (unless (= (status-word-count result) 16) (error "HOSTAT: bad word count ~D" (status-word-count result))) (format t "Site Name/Status Subnet #-in #-out abort lost crc ram bitc other~%~6O ~20A ~4O ~6D ~6D ~3D ~3D ~3D ~3D ~3D ~3D~%" (chaos::address-short addr) (status-node-name result) (status-subnet result) (status-packets-received result) (status-packets-transmitted result) (status-tx-aborts result) (status-rx-dropped result) (status-rx-crc-errors result) (status-rx-read-errors result) (status-rx-length-errors result) (status-rx-other-errors result)))) ;;;; ;;;; Network Control Program routines ;;;; ;;;; Support following: ;;;; ;;;; - maintain status information ;;;; - receive and transmit packets ;;;; -- for simple transactons ;;;; -- through connections ;;;; ;;;; compare to AI:LMIO;CHSNCP > ;;;; and AI:LMIO;CHSAUX > ;; these should probably be slots in a server or transceiver or ;; NCP object (defconstant +default-window-size+ #o15 "Default size of window for a connection") (defvar *packets-received* 0) (defvar *packets-transmitted* 0) (defvar *tx-aborts* 0) (defvar *rx-dropped* 0) (defvar *rx-crc-errors* 0) (defvar *rx-read-errors* 0) (defvar *rx-length-errors* 0) (defvar *rx-other-errors* 0) (defvar *pending-rfc-pkts* nil) (defparameter *pending-rfc-pkts-lock* (ccl::make-lock)) (defvar *pending-listens* nil) (defparameter *pending-listens-lock* (ccl::make-lock)) (defclass connection-packet () ((packet :accessor packet :initarg :packet :documentation "The underlying packet data") (time-transmitted :accessor time-transmitted :initarg :time-transmitted :initform 0 :documentation "The time this packet was (last) transmitted. Contains a result from GET-INTERNAL-REAL-TIME.") (transmission-count :accessor transmission-count :initarg :transmission-count :initform 0 :documentation "Number of times this packet has been transmitted"))) (defmethod make-connection-packet ((pkt packet)) (make-instance 'connection-packet :packet pkt)) (defclass connection () ((local-window-size :accessor local-window-size :initarg :local-window-size :initform +default-window-size+ :type 'integer) (foreign-window-size :accessor foreign-window-size :initarg :foreign-window-size :initform 0 :type 'integer) (state :accessor state :initarg :state :initform :inactive) (foreign-address :accessor foreign-address :initarg :foreign-address :type 'address) (foreign-index :accessor foreign-index :initarg :foreign-index :type 'connection-index) (local-index :accessor local-index :initarg :local-index :type 'connection-index) (read-packet-lock :accessor read-packet-lock :initarg :read-packet-lock :initform (ccl::make-lock) :documentation "This lock controls access to read-packets & received-packets") (read-packet-semaphore :accessor read-packet-semaphore :initarg :read-packet-semaphore :initform (ccl:make-semaphore) :documentation "Indicates availability of packets on read-packets") (send-packet-semaphore :accessor send-packet-semaphore :initarg :send-packet-semaphore :initform (ccl:make-semaphore) :documentation "Indicates availbility of window to transmit packets") (read-packets :accessor read-packets :initarg :read-packets :initform nil :documentation "A list of packets read from the net, and in order.") (received-packets :accessor received-packets :initarg :received-packets :initform nil :documentation "A list of packets received, but are not in order.") #|| ;; JAO: removing this as part of a redesigned locking scheme (count-lock :accessor count-lock :initform (ccl::make-read-write-lock) :documentation "This lock controls access to packet counters") ||# (pkt-num-read :accessor pkt-num-read :initarg :pkt-num-read :initform -1 :documentation "Highest number given to user") (pkt-num-received :accessor pkt-num-received :initarg :pkt-num-received :initform -1 :documentation "Highest number of packet in read-packets (in order)") (pkt-num-acked :accessor pkt-num-acked :initarg :pkt-num-acked :initform -1 :documentation "Level of acknowledgement sent.") (time-last-received :accessor time-last-received :initarg :time-last-received :initform 0 :documentation "Internal run time of last input from net") ;;; need a lock for outgoing packet lists (send-packet-lock :accessor send-packet-lock :initarg :send-packet-lock :initform (ccl::make-lock) :documentation "This lock controls access to send-packets") (send-pkts :accessor send-pkts :initform nil :documentation "List of packets which need to be potentially re-transmitted") (pkt-num-sent :accessor pkt-num-sent :initform 0 :documentation "Highest transmitted packet number assigned.") (send-pkt-acked :accessor send-pkt-acked :initform 0 :documentation "Last packet number for which we received acknowledgement") (send-pkt-receipted :accessor send-pkt-receipted :initform -1 :documentation "Highest packet number for which we received a receipt") (send-pkt-acked-lock :accessor send-pkt-acked-lock :initform (ccl::make-lock) :documentation "This lock controls access to send-pkt-acked & send-pkt-receipted") (window-available :accessor window-available :initform 0 :documentation "Space in window not occupied by unacknowledged packets.") (window-lock :accessor window-lock :initform (ccl::make-lock) :documentation "This lock controls access to window-available") )) (defvar *connection-hash-lock* (ccl::make-lock) "Control access to *connection-hash*") (defvar *connection-hash* (make-hash-table) "Hash table mapping incoming index numbers to connections") (defvar *promiscuous* nil "Whether to record all packets, including not for this address.") (defvar *packet-list-lock* (ccl::make-lock) "Control access to *packet-list*") (defvar *packet-list* nil "Contains list of packets not addressed to connections in *connection-hash*.") (defvar *last-connection-index* (short-index 1)) (defmethod connection-by-index ((index integer)) "Should hold *connection-hash-lock* to be sure..." (gethash index *connection-hash*)) (defmethod connection-by-index ((index connection-index)) (connection-by-index (index-short index))) (defun map-connections (fun) "For each CONN in the *connection-hash*, call (FUN CONN); return results in a list. N.B. HOLD *connection-hash-lock* for reading while calling this" (loop for conn being each hash-value of *connection-hash* collect (funcall fun conn))) (defun list-connections (&optional (stream *standard-output*)) (ccl::with-lock-grabbed (*connection-hash-lock*) (map-connections #'(lambda (conn) (format stream "~A~%" conn))))) (defun byte-1+-nonzero (byte) "Returns next value in sequence 1..255" (unless (integerp byte) (error "BYTE must be integer")) (if (or (< byte 1) (>= byte 255)) 1 (1+ byte))) (defmethod next-index ((index connection-index)) (let ((tidx (table-index index)) (uniq (uniqizer index))) (setf tidx (byte-1+-nonzero tidx)) (if (or (zerop uniq) (= tidx 1)) (setf uniq (byte-1+-nonzero uniq))) (make-instance 'connection-index :table-index tidx :uniqizer uniq))) (defun find-free-index () "Finds an unclaimed connection-index in *connection-hash*. One should hold a lock to avoid race conditions." (setf *last-connection-index* (do ((idx (next-index *last-connection-index*) (next-index idx))) ((multiple-value-bind (value present) (connection-by-index idx) (not present)) idx)))) (defun gen-connection () "Returns a new connection, interned into *connection-hash*, with a unique local connection index" (ccl::with-lock-grabbed (*connection-hash-lock*) (let* ((new-index (find-free-index)) (conn (make-instance 'connection :local-index new-index))) (setf (gethash (index-short new-index) *connection-hash*) conn) conn))) (defmethod make-rfc-connection ((incoming packet)) "Returns a freshly generated connection (with guaranteed unique connection index), suitable for responses to the INCOMING RFC packet." (let ((conn (gen-connection))) (setf (foreign-address conn) (sw-source-address incoming) (foreign-index conn) (source-index incoming) (foreign-window-size conn) 0 (state conn) :rfc-received (time-last-received conn) (get-internal-run-time)) conn)) (defmethod accept-packet-p ((pkt packet) &key (accept-broadcast t) (promiscuous nil) (accept-self nil) (my-address *chaos-address*)) (let ((dest-addr (hw-dest-address pkt)) (src-addr (hw-source-address pkt))) (let ((from-self (and (= (subnet src-addr) (subnet my-address)) (= (host src-addr) (host my-address)))) (to-me (and (= (subnet dest-addr) (subnet my-address)) (= (host dest-addr) (host my-address)))) (broadcast (or (and (zerop (subnet dest-addr)) (zerop (host dest-addr))) (and (= (subnet dest-addr) (subnet my-address)) (zerop (host dest-addr)))))) (or (and broadcast accept-broadcast) (and from-self accept-self) (and promiscuous (not from-self)) to-me)))) (defmethod malformed-packet ((pkt packet)) (cond ((> (data-byte-count pkt) +max-data-byte-count+) (incf *rx-length-errors*) t) (t nil))) (defun reading-packets () ;; &optional (chaos-socket *chaos-socket*)) "Function to wait for and process incoming packets." ;; NEED TO LOCK the stream?? ;; ;; should also specify the address and promiscuous mode ;; by encapsulating a "transceiver" in a single CLOS object ;; (ccl::process-input-wait (ccl::socket-os-fd chaos-socket)) ;; check for EOF on the stream?? (loop (let ((pkt (read-packet))) ; *chaos-socket*))) (when (accept-packet-p pkt :promiscuous *promiscuous*) ;; eventually, will identify connection here ;; and stick the packet into the connection's buffers (unless (malformed-packet pkt) (incf *packets-received*) (let ((hw-dest-addr (hw-dest-address pkt)) (op (opcode pkt))) (if (and (= (subnet hw-dest-addr) (subnet *chaos-address*)) (= (host hw-dest-addr) (host *chaos-address*))) ;; packet is to me (cond ((= op +rfc-op+) (receive-rfc pkt)) ((= op +los-op+) (receive-los pkt)) ((= op +cls-op+) (receive-cls pkt)) ((= op +mnt-op+) (format t "Discarding MNT packet.~%")) (t (let ((conn (pkt-dest-conn pkt))) (if conn (receive-conn-pkt pkt conn) (unless (= (opcode pkt) +sns-op+) ;; ignore SNS to non-existent connection, ;; otherwise complain by sending LOS (transmit-los-pkt pkt +los-op+ "No such index exists.")))))) ;; accept, but not addressed directly to me ;; could be broadcast or in promiscuous mode (ccl::with-lock-grabbed (*packet-list-lock*) (setf *packet-list* (append *packet-list* (list pkt))))))))))) (defmethod receive-conn-pkt ((pkt packet) (conn connection)) "Receive a packet directed to CONN" (format t "Receive conn ~A pkt ~A~%" conn pkt) (setf (time-last-received conn) (get-internal-run-time)) (let ((op (opcode pkt))) (cond ((not (address-= (sw-source-address pkt) (foreign-address conn))) (transmit-los-pkt pkt +los-op+ "You did not initiate this connection")) ((= op +opn-op+) (receive-opn conn pkt)) ((= op +fwd-op+) (receive-fwd conn pkt)) ((= op +ans-op+) (receive-ans conn pkt)) ((not (or (= op +sns-op+) (= op +sts-op+) (= op +eof-op+) (= op +unc-op+) (>= op +dat-op+))) (transmit-los-pkt pkt +los-op+ (format nil "Illegal opcode #x~X" op))) ((not (index-= (source-index pkt) (foreign-index conn))) (transmit-los-pkt pkt +los-op+ "That is not your index number for this connection")) ((not (eq (state conn) :open)) (unless (= op +sns-op+) (transmit-los-pkt pkt +los-op+ "Connection not open"))) ((= op +unc-op+) (receive-eof-unc-or-dat conn pkt)) (t ;; at this point, PKT has an acknowledgement ;; field that should be obeyed. (let ((ackn (ack-number pkt))) ;; (receipt conn ackn) (ccl:with-lock-grabbed ((send-pkt-acked-lock conn)) (when (pktnum-< (send-pkt-acked conn) ackn) (setf (send-pkt-acked conn) ackn)) ;; don't hold count-lock, u-w-a will grab again FIXME? (update-window-available conn))) (cond ((or (>= op +dat-op+) (= op +eof-op+)) (receive-eof-unc-or-dat conn pkt)) ((= op +sns-op+) (receive-sns conn pkt)) ((= op +sts-op+) (receive-sts conn pkt))))))) (defun contact-name-from-pkt (pkt) (let* ((str (data-string pkt)) (first-space (position #\space str))) (subseq str 0 first-space))) (defun receive-rfc (pkt) "Process a newly received RFC packet PKT. The routine *should* check pending RFC packets for duplication, look for connections LISTEN-ing for the RFC, and a list of server routines ready to be run in response." (labels ((duplicate-pending-rfc (pending) (and (address-= (sw-source-address pkt) (sw-source-address pending)) (index-= (source-index pkt) (source-index pending)))) (duplicate-connection (conn) (and (or (eq (state conn) :rfc-received) (eq (state conn) :open)) (address-= (foreign-address conn) (sw-source-address pkt)) (index-= (source-index pkt) (foreign-index conn))))) (let ((contact-name (contact-name-from-pkt pkt))) (format t "contact for ~A from ~A ~A~%" contact-name (sw-source-address pkt) (source-index pkt)) (cond ((ccl::with-lock-grabbed (*pending-rfc-pkts-lock*) (some #'duplicate-pending-rfc *pending-rfc-pkts*)) (format t "Discarding duplicate of pending~%") t) ; duplicate RFC, discard ((some #'identity (let (dup-test) (ccl::with-lock-grabbed (*connection-hash-lock*) (maphash #'(lambda (k v) (push (duplicate-connection v) dup-test)) *connection-hash*)) dup-test)) (format t "Discarding duplicate of connected~%")) ; duplicates RFC already dealt with (assuming connection hash is kept ; reasonably clean...), discard ;; handle STATUS with low overhead ((string= contact-name "STATUS") (format t "Got STATUS packet from ~A ~A~%" (sw-source-address pkt) (source-index pkt)) (let ((conn (make-rfc-connection pkt))) (answer conn (make-status-ans-packet)))) ;; check pending listens ((ccl:with-lock-grabbed (*pending-listens-lock*) (let ((matching-lsn-pair (assoc contact-name *pending-listens* :test #'string=))) (format t "Searched for matching listen for contact ~S result ~A~%" contact-name matching-lsn-pair) (when matching-lsn-pair (setf *pending-listens* (delete matching-lsn-pair *pending-listens*)) (format t "Found matching LSN ~A~%" matching-lsn-pair) (rfc-meets-lsn (cdr matching-lsn-pair) pkt) t)))) (t ;; LispM keeps *server-alist* to check for processes that ;; can be launched in response to an RFC (format t "Ignoring RFC for contact ~A~%" contact-name)))))) (defun receive-los (pkt) "An incoming LOS packet causes all packets on the destination conn, if it exists, and is in :OPEN-STATE, to be discarded." (let ((conn (pkt-dest-conn pkt))) (when (and conn (address-= (foreign-address conn) (sw-source-address pkt)) (index-= (foreign-index conn) (source-index pkt))) ; matches (ccl:with-lock-grabbed ((send-packet-lock conn)) (setf (send-pkts conn) nil)) (ccl:with-lock-grabbed ((read-packet-lock conn)) (setf (read-packets conn) (list pkt) (received-packets conn) nil (state conn) :los-received) (ccl:signal-semaphore (read-packet-semaphore conn)) (ccl:signal-semaphore (send-packet-semaphore conn)))))) (defun receive-cls (pkt) "Process incoming CLS. This might be destined for a non-existent connection, but that could simply be because this end transmitted a CLS of its own, and destroyed the corresponding connection. Therefore, such CLS packets are simply discarded." (let ((conn (pkt-dest-conn pkt))) (when conn (if (member (state conn) '(:open :rfc-sent)) (progn (ccl::with-lock-grabbed ((send-packet-lock conn)) (setf (send-pkts conn) nil) (ccl:signal-semaphore (send-packet-semaphore conn))) (ccl::with-lock-grabbed ((read-packet-lock conn)) (setf (read-packets conn) (append (read-packets conn) (list pkt)) (received-packets conn) nil (state conn) :cls-received) (ccl:signal-semaphore (read-packet-semaphore conn))) (transmit-los-pkt pkt +los-op+ "You sent a CLS to the wrong kind of connection")))))) (defmethod receive-ans ((conn connection) (pkt packet)) (unless (eq (state conn) :rfc-sent) (transmit-los-pkt pkt +los-op+ "An ANS was sent to a non-RFC-SENT index")) (ccl:with-lock-grabbed ((read-packet-lock conn)) (setf (read-packets conn) (list pkt)) (ccl:signal-semaphore (read-packet-semaphore conn)) (setf (state conn) :answered))) (defmethod accept ((conn connection)) "CONN must be in the RFC Received state. An OPN packet will be transmitted, and CONN will enter the :OPEN state. If the RFC packet has not already been read with chaos:get-next-packet, it is discarded. You should read it before accepting if the RFC has arguments in addition to the contact name." (unless (eq (state conn) :rfc-received) (error "Attempt to accept ~S in state ~A, not :RFC-RECEIVED" conn (state conn))) ;; discard unread packet, if it is there (ccl::with-lock-grabbed ((read-packet-lock conn)) (when (read-packets conn) (when (cdr (read-packets conn)) (format t "MORE THAN ONE PACKET: ACCEPT~%")) (setf (pkt-num-received conn) (packet-number (car (read-packets conn))) (read-packets conn) nil)) (setf (window-available conn) 0 ;; CANNOT SEND UNTIL GET STS (state conn) :open)) (transmit-opn conn) conn) (defmethod reject ((conn connection) reason) (if (eq (state conn) :rfc-received) (let ((pkt (make-instance 'packet))) (set-pkt-string pkt reason) (setf (opcode pkt) +cls-op+) (transmit-normal-pkt conn pkt) (remove-conn conn)) (error "Attempt to REJECT connection ~A in state ~A not :RFC-RECEIVED~%" conn (state conn)))) (defmethod answer ((conn connection) (pkt packet)) (format t "answering conn in state ~A~%" (state conn)) (when (eq (state conn) :rfc-received) (setf (opcode pkt) +ans-op+) (format t "Answering...~%") (transmit-normal-pkt conn pkt)) (remove-conn conn)) (defmethod answer-string ((conn connection) (string string)) (let ((pkt (make-instance 'packet))) (set-pkt-string pkt string) (format t "set packet string") (answer conn pkt))) (defmethod wait-conn-leave-state ((conn connection) state &optional timeout-seconds (wait-line "CHAOS wait")) (ccl::process-wait-with-timeout wait-line (when timeout-seconds (round (* timeout-seconds ccl:*ticks-per-second*))) #'(lambda (conn) (not (eq (state conn) state))) conn)) (defmethod make-transmit-connection ((dest-addr address) &optional (window-size +default-window-size+)) (let ((conn (gen-connection))) (setf (foreign-address conn) dest-addr (local-window-size conn) window-size (time-last-received conn) (get-internal-run-time) (foreign-index conn) (short-index 0)) ; not known yet conn)) (defmethod make-transmit-connection ((dest-addr integer) &optional (window-size +default-window-size+)) (make-transmit-connection (short-address dest-addr) window-size)) (defmethod get-next-pkt ((conn connection) &optional no-hang) (let ((result (if no-hang (ccl:timed-wait-on-semaphore (read-packet-semaphore conn) 0) (ccl:wait-on-semaphore (read-packet-semaphore conn))))) (when (and no-hang (null result)) (return-from get-next-pkt nil)) ; can we miss packets here? (ccl:with-lock-grabbed ((read-packet-lock conn)) (let ((pkt (pop (read-packets conn)))) ;; several cases. ;; 1. ordinary packet, return it and mark received by process ;; 2. no packet. If no-hang, then either because wait-on-semaphore ;; returned a system error, or some other get-next-pkt signalled ;; the semaphore because of a transition to a bad state. ;; 3. LOS packet. stick it back on, signal the semaphore and ;; return it. (when (and pkt (/= (opcode pkt) +unc-op+)) (setf (pkt-num-read conn) (packet-number pkt))) ;; is this really the right condition? CLS packets update ;; pkt-num-read? ;; check window... (cond ((and (null pkt) no-hang) nil) ; not sure if this is caught above ((null pkt) ; didn't get a packet, state must be wrong (ccl:signal-semaphore (read-packet-semaphore conn)) (state conn)) ((= (opcode pkt) +los-op+) (push pkt (read-packets conn)) (ccl:signal-semaphore (read-packet-semaphore conn)) (data-string pkt)) (t pkt)))))) #| (defmethod get-next-pkt-blocking ((conn connection)) (ccl:process-wait "Chaos Input" #'data-available conn) (get-next-pkt conn)) |# (defun finished-p (conn) (or (not (eq (state conn) :open)) (>= (window-available conn) (foreign-window-size conn)))) (defmethod chaos:finish ((conn connection) &optional (whostate "Chaos Finish")) "Wait until all output is acknowledged, or CONN is no longer open. Returns T unless the CONN ceased to be open." (ccl:process-wait whostate #'finished-p conn) (eq (state conn) :open)) (defmethod receipt ((conn connection) ack-level) "Update connection to reflect acknowledgement by NCP on other end of packets up to ACK-LEVEL. The retransmission process will not retransmit these packets, and will remove them from send-list of CONN." ;; NOTE: in newer locking regime, the retransmission process ;; should do the list surgery. (format t "Marking receipt conn ~A level ~D~%" conn ack-level) (setf (send-packet-receipted conn) ack-level)) #|| (ccl:with-lock-grabbed ((send-packet-lock conn)) (setf (send-pkts conn) (delete-if #'(lambda (cpkt) (not (pktnum-< ack-level (packet-number (packet cpkt))))) (send-pkts conn))))) ||# (defmethod open-connection ((addr address) contact-name &optional (window-size +default-window-size+)) (let ((conn (make-transmit-connection addr window-size)) (pkt (make-instance 'packet))) (setf (opcode pkt) +rfc-op+) (set-pkt-string pkt contact-name) (setf (state conn) :rfc-sent) (format t "Sending packet ~A to conn ~A.~%" pkt conn) (transmit-pkt conn pkt nil) conn)) (defmethod simple ((addr address) contact-name &optional timeout-seconds) "Taking arguments similar to those of chaos:connect, this performs the user side of simple-transaction. The retured value is either an ANS packet or a string containing a failure message. [the Chaosnet memo requires the ANS packet be disposed using chaos:return-pkt, but not for this implementation]" ;;; based on CHSAUX, should be able to use OPEN-CONNECTION, so ;;; perhaps implement that (format t "Making simple contact ~A to ~A~%" contact-name addr) (let ((conn (open-connection addr contact-name))) (wait-conn-leave-state conn :rfc-sent timeout-seconds "Waiting for ANS") (cond ((eq (state conn) :rfc-sent) (remove-conn conn) "Host not responding.") ((eq (state conn) :answered) (format t "in state answered~%") (let ((return-pkt (get-next-pkt conn))) (remove-conn conn) return-pkt)) ((eq (state conn) :cls-received) (format t "in state cls-received~%") (let ((return-string (data-string (get-next-pkt conn)))) (remove-conn conn) return-string)) ((eq (state conn) :open) (chaos:close conn "I expected an ANS not an OPN.") "Received an OPN instead of an ANS.") (t (let ((return-string (format nil "Bad state: ~A" (state conn)))) (remove-conn conn) return-string))))) (defmethod connect ((addr address) contact-name &optional timeout) (format t "Making full contact ~A to ~A~%" contact-name addr) (let ((conn (open-connection addr contact-name))) (wait-conn-leave-state conn :rfc-sent timeout "Waiting for OPN") (case (state conn) (:open conn) (:rfc-sent (chaos:close conn) (remove-conn conn) "Host not responding.") (:answered (chaos:close conn) (remove-conn conn) "Received an ANS instead of an OPN") (:cls-received (let ((pkt (get-next-pkt conn))) (chaos:close conn) (remove-conn conn) (data-string pkt))) (t (let ((str (ccl::with-lock-grabbed ((read-packet-lock conn)) (and (read-packets conn) (data-string (car (read-packets conn))))))) (remove-conn conn) (format nil "Bad state in CHAOS:CONNECT ~A ~@[, ~A~]" (state conn) str)))))) (defmethod remove-conn ((conn connection)) "Makes CONN null and void. It becomes inactive, all buffered packets are freed, and the corresponding Chaosnet connection (if any) goes away." (setf (state conn) :inactive) (ccl:signal-semaphore (send-packet-semaphore conn)) (ccl:signal-semaphore (read-packet-semaphore conn)) (ccl:with-lock-grabbed (*connection-hash-lock*) (remhash (index-short (local-index conn)) *connection-hash*))) (defmethod close ((conn connection) &optional reason) "Closes and removes the connection. If open, a CLS packet is sent containing the string REASON. Don't use this to reject RFC's; use CHAOS:REJECT for that." (case (state conn) ((:cls-received :answered) (remove-conn conn) nil) (:inactive nil) (:open (let ((cls-pkt (make-instance 'packet))) (if reason (set-pkt-string cls-pkt reason) (setf (data-byte-count cls-pkt) 0)) (setf (opcode cls-pkt) +cls-op+) (transmit-pkt conn cls-pkt) (remove-conn conn) nil)) ((:los-received :host-down :listening :rfc-sent) (remove-conn conn) nil) (t (error "Attempt to close ~S, which was in ~S, not an acceptable state~%" conn (state conn))))) (defun listen (contact-name &optional (window-size +default-window-size+) (wait-for-rfc t)) "Waits for an incoming RFC for contact CONTACT-NAME; If WAIT-FOR-RFC is NIL, returns a new connection immediately, in state :LISTEN; when the RFC comes in, the connection state will change to :RFC-RECEIVED. If WAIT-FOR-RFC is non-NIL (the default), the process will block until an RFC arrives, and the connection returned will already be in the state :RFC-RECEIVED. A connection is returned; when in the :RFC-RECEIVED state, the RFC packet ready to be read by CHAOS:GET-NEXT-PKT. At that time, use CHAOS:ANSWER, CHAOS:ANSWER-STRING, CHAOS:ACCEPT, CHAOS:REJECT, or CHAOS:FORWARD to respond." (let ((conn (gen-connection))) (format t "Listening on connection ~A~%" conn) (setf (local-window-size conn) (max 1 window-size) (foreign-window-size conn) 0) ;; scan for any RFC's already arrived for this contact (let ((rfc (ccl::with-lock-grabbed (*pending-rfc-pkts-lock*) (find-if #'(lambda (p) (string= contact-name (contact-name-from-pkt p))) *pending-rfc-pkts*)))) (if rfc (progn ;; found a pending RFC, you get it (format t "listen found an already pending RFC~%") (ccl:with-lock-grabbed (*pending-rfc-pkts-lock*) (setf *pending-rfc-pkts* (delete rfc *pending-rfc-pkts*))) (rfc-meets-lsn conn rfc)) ;; no pending RFC, go into listening state (progn (format t "Putting conn into :listening state~%") (setf (state conn) :listening) (ccl:with-lock-grabbed (*pending-listens-lock*) (push (cons contact-name conn) *pending-listens*)) (when wait-for-rfc (format t "Waiting for RFC to come in.~%") (wait-conn-leave-state conn :listening nil (format nil "Listening for ~A~%" contact-name)) (unless (eq (state conn) :rfc-received) (error "Bad response on LISTEN ~A ~A~%" contact-name conn))) conn))))) (defmethod rfc-meets-lsn ((conn connection) (pkt packet)) "Processes a packet containing an RFC matching the contact name that was specified for CONN." (setf (foreign-address conn) (sw-source-address pkt) (foreign-index conn) (source-index pkt) (pkt-num-read conn) (packet-number pkt) (pkt-num-acked conn) (packet-number pkt) (foreign-window-size conn) (ack-number pkt) (time-last-received conn) (get-internal-run-time)) (ccl:with-lock-grabbed ((read-packet-lock conn)) (push pkt (read-packets conn))) ;; (ccl:signal-semaphore (read-packet-semaphore conn)) ;; use this if I decide listen should wait for the semaphore instead of ;; waiting for the state to change (setf (state conn) :rfc-received)) #| (defun start-listener () ;; NEED TO LOCK the stream?? (ccl:process-run-function "CHAOS NCP Process" #'reading-packets)) |# (defun start-chaos () (connect-to-server) (values (ccl:process-run-function "CHAOS NCP Process" #'reading-packets) (ccl:process-run-function "CHAOS Retransmit Process" #'retransmit-process) )) (defconstant +CHAOS-PACKET-NUM-LIMIT+ 65536 "The number of distinct packet numbers allowed.") (defun pktnum-1+ (num) "Calculates the next packet number in sequence following NUM." (mod (1+ num) +CHAOS-PACKET-NUM-LIMIT+)) (defun pktnum-< (num1 num2) (logbitp 15 (- num1 num2))) (defun pktnum-- (a b) "Separation in packet number between packet numbers A and B; ASSUMES A actually is later in packet sequence than B, but might have wrapped around." (let ((diff (- a b))) (if (< diff 0) (+ diff +chaos-packet-num-limit+) diff))) (defmethod route-packet ((pkt packet) &optional (hw-source-address *chaos-address*)) "Set hardware destination address and hardware source address based on software destination address indicated in the packet and the optional argument. [For now, simply copies the sw destination]" (setf (hw-dest-address pkt) (sw-dest-address pkt) (hw-source-address pkt) hw-source-address) pkt) ;;; heirarchy of LISPM transmit routines; possibly unnecessary for ;;; an implementation that does not rely on low-level hardware ;;; interrupts ;;; - note LISPM packets have both the byte data and the PKT-LEADER ;;; which has the PKT-TIME-TRANSMITTED, PKT-LINK, PKT-MADE-LINK ;;; PKT-BEING-RETRANSMITTED flag, and a PKT-STATUS flag indicating ;;; if it has been handed to a user routine; I use the CONNECTION-PACKET ;;; to hold that data. ;;; ;;; I suppose I need to define methods that "wrap" a raw PACKET ;;; with a CONNECTION-PACKET on demand. ;;; ;;; user uses (SEND-PKT conn cpkt opcode) for controlled packets and EOF ;;; when CONN has window open, and has not left the :open state ;;; calls ;;; (TRANSMIT-NORMAL-PKT CONN cpkt T T) [which mutates fields] ;;; then, puts it onto the SEND-PKTS list of the CONN and ;;; raises the RETRANSMISSION-NEEDED flag ;;; if CONN's state has instead become :LOS-RECEIVED while waiting ;;; for the window, that causes an error, or if CONN is any non-:OPEN ;;; state ;;; ;;; (SEND-STRING CONN &rest STRINGS) ;;; simply calls SEND-PKT with a new packet filled with the data in ;;; STRINGS, with opcode DAT-OP ;;; ;;; (SEND-UNC-PKT conn pkt &optional (pktn-field (pkt-num pkt)) ;;; (ack-field (pkt-ack-num pkt))) ;;; sets UNC-OP as opcode, ;;; (transmit-normal-pkt conn pkt pktn-field ack-field) ;;; ;;; (TRANSMIT-NORMAL-PKT conn cpkt &optional (pktn 0) ;;; (ack-pktn 0)) ;;; normal means "not LOS nor DATA" ;;; if PKTN or ACK-PKTN are T, it means the numbers should ;;; be the natural ones for a controlled packet ;;; opcode of cpkt must be already set ;;; **sets the connection fields (addresses & indexes) to match CONN** ;;; calls (TRANSMIT-PKT pkt ACK-P) where ACK-P is T if ACK-PKTN was T ;;; ;;; (TRANSMIT-PKT cpkt &optional ackp) ;;; ...N.B. CONN not passed in... ;;; (i guess because it is "also called by the retransmitter & forwarder" ;;; who don't care which CONN it was for??) ;;; ;;; in the case of ACK-P being true, WITHOUT-INTERRUPTS, ;;; looks up the corresponding CONN by (PKT-SOURCE-CONN pkt) ;;; (error if the CONN has gone missing...) ;;; and updates the PKT-ACK-NUM of the pkt to reflect PKT-NUM-READ of ;;; the CONN and the PKT-NUM-ACKED of the CONN to reflect that this ;;; PKT-ACK-NUM is (about to be) acknowledged. ;;; ;;; updates the pkt-time-transmitted and pkt-times-transmitted of the ;;; pkt, ;;; ;;; and (transmit-int-pkt (convert-to-int-pkt pkt)) ;;; ;;; (don't quite understand the conversion: I guess that copies the ;;; data into wired space (int-pkt) for the microcode to actually send to the ;;; interface, but that int-pkt will be volatile after the transmission, so ;;; it needs to re-convert-to-int-pkt when the retransmission happens? ;;; ;;; (TRANSMIT-INT-PKT-FOR-CONN conn pkt) ;;; ..updates (int-?)pkt's source address, source index, dest-address, ;;; dest-index to match MY-ADDRESS and the CONN ;;; WITHOUT-INTERRUPTS...updates sets the PKT-ACK-NUM and PKT-NUM-ACKED ;;; of CONN to reflect the PKT-NUM-READ of CONN. ;;; (transmit-int-pkt pkt) ;;; ;;; (TRANSMIT-INT-PKT int-pkt &optional (host (pkt-dest-address int-pkt)) ;;; (subnet (pkt-dest-subnet))) ;;; .. if subnet != my-subnet, does a simple lookup in routing-table ;;; and updates HOST accordingly ;;; [I suppose the routing table may have changed in the meantime, since ;;; the last re-transmission] ;;; .. sets int-pkt-word-count ;;; .. (aset host int-pkt (1- (int-pkt-word-count int-pkt))) ;;; [which I think sets the HW destination to the (newly-routed) HOST] ;;; .. increments pkts-transmitted ;;; .. spins around until it can stick the int-pkt onto ;;; int-transmit-list-pointer? ;;; .. (%chaos-wakeup)? #| ;; deprecate in favor of semaphore based signalling (defmethod may-transmit ((conn connection)) "Returns non-nil if a packet can be sent on CONN." (let ((wa (window-available conn))) (and wa (> wa 0)))) (defmethod data-available ((conn connection)) "Should probably deprecate this...use semaphore signalling instead." (ccl::with-read-lock ((read-packet-lock conn)) (not (null (read-packets conn))))) |# (defmethod send-pkt ((conn connection) (pkt packet) &optional (opcode +dat-op+)) "Tries to obey windowing, and sends PKT on CONN. Should be used only for controlled packets, because they will be re-transmitted" (format t "sending packet ~A on conn ~A~%" pkt conn) (unless (eql (state conn) :open) (error "Attempt to send packet on ~A in state ~A~%" conn (state conn))) ;; could specially detect LOS, echo received LOS message (unless (or (= opcode +eof-op+) (<= #o200 opcode #o377)) (error "Attempt to send packet with invalid opcode #o~O~%" opcode)) (setf (opcode pkt) opcode) (format t "Waiting on semaphore~%") (ccl:wait-on-semaphore (send-packet-semaphore conn)) (format t "Got semaphore~%") ;;(ccl::process-wait "Net Output" ;; #'(lambda (conn) ;; (or (may-transmit conn) ;; (not (eql (state conn) :open)))) ;; conn) (unless (eql (state conn) :open) (ccl:signal-semaphore (send-packet-semaphore conn)) (error "Attempt to send a packet on ~S which went into state ~S" conn (state conn))) (format t "Decrementing window~%") (ccl::with-lock-grabbed ((window-lock conn)) (decf (window-available conn))) (format t "Decremented window, transmitting packet~%") (transmit-normal-pkt conn pkt t t) ;; holding a lock, put the packet on the transmit list so that ;; it can be retransmitted appropriately. ;; (no-one is in charge of doing so yet.) (format t "Putting on send-pkts list for retranmission~%") (let ((cpkt (make-connection-packet pkt))) (setf (time-transmitted cpkt) (get-internal-run-time)) (ccl::with-lock-grabbed ((send-packet-lock conn)) (send-pkts conn) (append (send-pkts conn) (list cpkt)))) (format t "send-pkt done.~%")) ;; wake up retransmitter? any locks needing to be held for that? ;; (setf retransmission-needed t) (defmethod send-string ((conn connection) &rest strings) "Sends a DAT packet containing the concatenation of the STRINGS" (let ((pkt (make-instance 'packet))) (apply #'set-pkt-string pkt strings) (send-pkt conn pkt))) (defmethod transmit-int-pkt ((pkt packet)) "Routes and transmits a packet to the sw-destination" (write-packet (route-packet pkt))) (defmethod transmit-int-pkt ((cpkt connection-packet)) "[TO DO Put a connection-packet on the transmit list]; also puts in the hardware addresses to route to the sw-destination" ;; (error "transmit-int-pkt not implemented yet") ;; look up routing table for the sw destination, set the ;; hw destination ;; set the hardware source (setf (time-transmitted cpkt) (get-internal-real-time)) (transmit-int-pkt (packet cpkt))) ;; I think I should send the packet down the pipe ;; -- the Lisp machine implementation has a hardware interrupt ;; when the output buffer is empty, but the user-mode pipe ;; should always be ready (defmethod transmit-pkt ((conn connection) (pkt packet) &optional ack-p) ;; SHOULD I not put the packet on the transmit list? ;; uncontrolled packets should not be retransmitted, so they ;; should not remain on the send-pkt list. "Puts a packet on the transmit list, wrapped in a connection-packet ALSO: sets up destination address and index corresponding to connection" (format t "transmit-pkt ~A on ~A ack-p ~A~%pkt-num-read is ~D pkt-num-acked is ~D~%" pkt conn ack-p (pkt-num-read conn) (pkt-num-acked conn)) (setf (sw-source-address pkt) *chaos-address* (source-index pkt) (local-index conn) (sw-dest-address pkt) (foreign-address conn) (dest-index pkt) (foreign-index conn)) (let ((cpkt (make-connection-packet pkt))) (when ack-p (let ((ackn (pkt-num-read conn))) (format t "will send ack for pkt ~D~%" ackn) (setf (ack-number pkt) ackn (pkt-num-acked conn) ackn))) (transmit-int-pkt cpkt))) (defmethod transmit-normal-pkt ((conn connection) (pkt packet) &optional (pkt-num 0) (ack-pkt-num 0)) "Send a normal packet (i.e., not LOS nor DATA). The opcode, packet length, and data should already be initialized. If PKT-NUM or ACK-PKT-NUM are T, then they assume the appropriate (controlled?) values for the connection." ;;; need to hold count lock to get the packet number (format t "transmit-normal-pkt: ~A on ~A~%pkt-num-sent is ~D~%" pkt conn (pkt-num-sent conn)) (when (eq pkt-num t) (setf pkt-num (pktnum-1+ (pkt-num-sent conn)) (pkt-num-sent conn) pkt-num)) (setf (packet-number pkt) pkt-num) (let (ack-p) (if (eq ack-pkt-num t) (setf ack-p t) (setf (ack-number pkt) ack-pkt-num)) ;; (setf (sw-source-address pkt) *chaos-address* ;; (source-index pkt) (local-index conn) ;; (sw-dest-address pkt) (foreign-address conn) ;; (dest-index pkt) (foreign-index conn)) (transmit-pkt conn pkt ack-p))) (defmethod transmit-los-pkt ((pkt packet) opcode &optional reason) "Given an inappropriate PKT (including a RFC to reject), construct a LOS response and transmit it (back in the opposite direction of PKT)." (let ((los-pkt (make-instance 'packet))) (when reason (set-pkt-string los-pkt reason)) (setf (opcode los-pkt) opcode (sw-source-address los-pkt) (sw-dest-address pkt) (sw-dest-address los-pkt) (sw-source-address pkt) (dest-index los-pkt) (source-index pkt) (source-index los-pkt) (dest-index pkt) (ack-number los-pkt) (ack-number pkt) (packet-number los-pkt) (packet-number pkt)) (transmit-int-pkt los-pkt))) #| (defun test-listen () (let ((conn (chaos::listen "TEST" chaos::+default-window-size+ t))) (format t "Got RFC...trying to answer.") (chaos::answer-string conn "TEST RESPONSE"))) ;; on the Lisp Machine simulator, try ;; (setf *pkt* (chaos:simple 402 "TEST")) ;; will return a Chaos packet ;; (chaos:pkt-string *pkt*) should return "TEST RESPONSE" ;; (chaos:return-pkt *pkt*) to be safe |# (defmethod pkt-dest-conn ((pkt packet)) (ccl::with-lock-grabbed (*connection-hash-lock*) (connection-by-index (dest-index pkt)))) ;; OPN and STS have the same data format (define-packet-word sts-receipt +sw-header-bytes+ "STS word containing the latest packet number up to which the NCP on the other end of the connection has successfully received all packets in order.") (define-packet-word sts-window-size (+ +sw-header-bytes+ 2) "STS word containing current window length for the end of the connection transmitting the STS.") (defmethod receive-opn ((conn connection) (pkt packet)) (cond ((eq (state conn) :rfc-sent) (setf (foreign-index conn) (source-index pkt) (foreign-window-size conn) (sts-window-size pkt)) (setf (pkt-num-read conn) (packet-number pkt) (pkt-num-received conn) (packet-number pkt) (pkt-num-acked conn) (packet-number pkt) (time-last-received conn) (get-internal-run-time)) (ccl:with-lock-grabbed ((send-pkt-acked-lock conn)) (setf (send-pkt-acked conn) (ack-number pkt)) ;; (receipt conn (ack-number pkt)) ; remove RFC? (update-window-available conn)) (setf (state conn) :open) (transmit-sts conn +opn-op+)) ((eq (state conn) :open) ; possible duplicate OPN, or my STS was lost (if (and (address-= (foreign-address conn) (sw-source-address pkt)) (address-= *chaos-address* (sw-dest-address pkt)) (index-= (foreign-index conn) (source-index pkt)) (index-= (local-index conn) (dest-index pkt))) ; should be already (transmit-sts conn +opn-op+) (transmit-los-pkt pkt +los-op+ "You didn't open this connection"))) (t (transmit-los-pkt pkt +los-op+ "Bad state for OPN")))) (defmethod transmit-sts ((conn connection) why-op) (let ((pkt (make-instance 'packet))) (setf (opcode pkt) +sts-op+ (data-byte-count pkt) 4) (setf (sts-receipt pkt) (pkt-num-received conn) (sts-window-size pkt) (local-window-size conn)) (transmit-pkt conn pkt))) #| (defmethod transmit-cls ((conn connection) reason) (let ((pkt (make-instance 'packet))) (setf (opcode pkt) +cls-op+ (data-string pkt) reason) (transmit-pkt conn pkt))) |# (defmethod transmit-eof ((conn connection)) (let ((pkt (make-instance 'packet))) (setf (data-byte-count pkt) 0) (send-pkt conn pkt +eof-op+))) (defmethod transmit-opn ((conn connection)) "Need to put OPN packet on send-pkts in order to trigger retransmission." (let ((pkt (make-instance 'packet))) (setf (opcode pkt) +opn-op+ (data-byte-count pkt) 4) (setf (sts-receipt pkt) (pkt-num-received conn) (sts-window-size pkt) (local-window-size conn)) (transmit-pkt conn pkt))) (defmethod update-window-available ((conn connection)) "Will grab window-lock of CONN" (format t "updating window of ~A~%" conn) (ccl::with-lock-grabbed ((window-lock conn)) (let* ((avail (window-available conn)) (new-avail (max 0 avail (- (foreign-window-size conn) (pktnum-- (pkt-num-sent conn) (send-pkt-acked conn)))))) (format t "avail was ~D new-avail is ~D~%" avail new-avail) (setf (window-available conn) new-avail) ;; unsatisfactory attempt to modify semaphore value to ;; reflect change (if (> new-avail avail) (dotimes (i (- new-avail avail)) (ccl:signal-semaphore (send-packet-semaphore conn))) (dotimes (i (- avail new-avail)) (ccl:timed-wait-on-semaphore (send-packet-semaphore conn) 0)))))) (defmethod receive-sns ((conn connection) (pkt packet)) "Called to respond to incoming SNS, verified to be in OPEN-STATE?" (transmit-sts conn :SNS)) (defmethod receive-sts ((conn connection) (pkt packet)) "Called to respond to incoming STS." ;; ;;(ccl::with-lock ((send-pkt-acked-lock conn)) ;;;; (setf (send-pkt-acked conn) (sts-receipt pkt) (ccl:with-lock-grabbed ((send-pkt-acked-lock conn)) (let ((curr-receipt (send-pkt-receipted conn)) (new-receipt (sts-receipt pkt))) (when (pktnum-< curr-receipt new-receipt) (setf (send-pkt-receipted conn) new-receipt)) (setf (foreign-window-size conn) (sts-window-size pkt)))) (update-window-available conn)) (defmethod receive-fwd ((conn connection) (pkt packet)) (error "RECEIVE-FWD not implemented yet.")) (defmethod receive-eof-unc-or-dat ((conn connection) (pkt packet)) "Receives a packet to be delivered to the user, updating the in-order and out-of-order packet lists according to the packet number sequence." (let ((pkt-num (packet-number pkt))) (format t "got packet number ~D opcode #x~X~%" pkt-num (opcode pkt)) (if (= +unc-op+ (opcode pkt)) ; UNC packets go to the head of the line? (progn (format t "inserting UNC packet at head~%") (ccl:with-lock-grabbed ((read-packet-lock conn)) (push pkt (read-packets conn)) (format t "signalling~%") (ccl:signal-semaphore (read-packet-semaphore conn)))) (progn (format t "checking~%") (ccl:with-lock-grabbed ((read-packet-lock conn)) (cond ((not (pktnum-< (pkt-num-received conn) pkt-num)) ;; duplicate, receipt and ignore ;; (incf *pkts-duplicated*) (transmit-sts conn :<-num-rcvd)) ((= pkt-num (pktnum-1+ (pkt-num-received conn))) ;; add to read-packets, possibly promoting ;; formerly out-of-order packets from received-packets (setf (read-packets conn) (append (read-packets conn) (list pkt))) (ccl:signal-semaphore (read-packet-semaphore conn)) (promote-received-packets conn) (setf (pkt-num-received conn) (packet-number (car (last (read-packets conn)))))) (t ;; not in order, add to received-packets in ;; proper location (insert-received-packet conn pkt)))))))) (defmethod promote-received-packets ((conn connection)) "Promote any newly-in-order packets as necessary. Please grab READ-PACKET-LOCK of CONN for writing before calling." (let ((last-ordered-packet (car (last (read-packets conn)))) (received-packets (received-packets conn))) (do ((num 0 (1+ num)) (prev last-ordered-packet (car ptr)) (ptr received-packets (cdr ptr))) ((or (null ptr) (/= (packet-number (car ptr)) (pktnum-1+ (packet-number prev)))) (let ((pkts-in-order (subseq received-packets 0 num)) (pkts-out-of-order (subseq received-packets num))) (setf (read-packets conn) (append (read-packets conn) pkts-in-order) (received-packets conn) pkts-out-of-order) (dotimes (i num) (ccl:signal-semaphore (read-packet-semaphore conn)))))))) (defmethod insert-received-packet ((conn connection) (pkt packet)) (let ((pkt-num (packet-number pkt))) (labels ((insert-into-list (list) (cond ((null list) (list pkt)) ((= pkt-num (packet-number (car list))) list) ; duplicate, drop it ((pktnum-< pkt-num (packet-number (car list))) (cons pkt list)) (t (cons (car list) (insert-into-list (cdr list))))))) (setf (received-packets conn) (insert-into-list (received-packets conn)))))) #| ;;; some exercises sending packets over connection ;;; ;;; on CADR simulator ;;; (setf *conn1* (chaos:listen "CADRTEST" 13. nil)) ;;; (setf *conn2* (chaos:connect 401 "CADRTEST")) ;;; ---> hangs, sending (and rteransmitting) RFC's, but can't ;;; come back to accept. ;;; ;;; (chaos:wait *conn1* chaos:listening-state 1 "complete connect") ;;; (chaos:accept *conn1*) ;;; (chaos:send-string *conn2* "TWO to ONE") ;;; (chaos:send-string *conn1* "ONE to TWO") ;;; (setf *pkt1* (chaos:get-next-pkt *conn1*)) ;;; (setf *pkt2* (chaos:get-next-pkt *conn2*)) ;;; (prog1 (list (chaos:pkt-string *pkt1*) (chaos:pkt-string *pkt2*)) ;;; (chaos:return-pkt *pkt1*) ;;; (chaos:return-pkt *pkt2*)) ;;; (chaos:close *conn1*) ;;; (chaos:close *conn2*) (defvar *result1*) (defun test-local-server () (setf *result1* nil) (labels ((conn1 () (let ((conn1 (chaos::accept (chaos::listen "LOCALTEST")))) (chaos::send-string conn1 "ONE to TWO") (ccl:process-wait "data in" #'(lambda (conn) (chaos::data-available conn)) conn1) (let ((pkt1 (chaos::get-next-pkt conn1))) (setf *result1* (if pkt1 (chaos::data-string pkt1) "Conn1 didn't get packet")))))) (ccl:process-run-function "CONN1" #'conn1))) (defun test-local-client () (let ((conn2 (chaos::connect chaos::*chaos-address* "LOCALTEST"))) (chaos::send-string conn2 "TWO to ONE") (chaos::data-string (chaos::get-next-pkt conn2)))) (defun test-packets-2 () (let (*result1* *result2*) (declare (special *result1* *result2*)) (labels ((conn1 () (let ((conn1 (chaos::accept (chaos::listen "LOCALTEST")))) (chaos::send-string conn1 "ONE to TWO") (setf *result1* (chaos::data-string (chaos::get-next-pkt conn1)))))) (let ((proc1 (ccl::process-run-function "CONN1" #'conn1)) (conn2 (chaos::connect chaos::*chaos-address* "LOCALTEST"))) (chaos::send-string conn2 "TWO to ONE") (ccl::process-allow-schedule) (let ((pkt1 (chaos::get-next-pkt conn2))) (list (when pkt1 (chaos::data-string pkt1)) *result1*)))))) (defun test-packets-1 () (let (*result1* *result2*) (declare (special *result1* *result2*)) (labels ((conn1 () (let ((conn1 (chaos::accept (chaos::listen "LOCALTEST")))) (chaos::send-string conn1 "ONE to TWO") (setf *result1* (chaos::data-string (chaos::get-next-pkt conn1)))))) (conn2 (chaos::connect chaos::*chaos-address* "LOCALTEST"))) (chaos::send-string conn2 "TWO to ONE") (setf *result2* (chaos::data-string (chaos::get-next-pkt conn2)))) (let ((proc1 (ccl::process-run-function "CONN1" #'conn1)) (proc2 (ccl::process-run-function "CONN2" #'conn2))) (ccl::process-allow-schedule) (ccl::process-wait "transaction" #'(lambda (result1 result2) (and result1 result2)) *result1* *result2*) (values *result1* *result2*))))) |# (defmethod print-conn ((conn connection)) "Print relevant information about connection to *standard-output*" (format t "Chaos connection: ~A State: ~S From: #o~O-~O to ~O-~O.~%" (local-index conn) (state conn) (address-short *chaos-address*) (index-short (local-index conn)) (address-short (foreign-address conn)) (index-short (foreign-index conn))) (format t "Rcvd #o~O, Read #o~O, Acked #o~O; Sent #o~O, Acked #o~O.~%" (pkt-num-received conn) (pkt-num-read conn) (pkt-num-acked conn) (pkt-num-sent conn) (send-pkt-acked conn)) (format t "Windows: ~D, ~D (~D available)~%" (local-window-size conn) (foreign-window-size conn) (window-available conn)) ;; print send-packets ;; print read-packets ;; print received-packets ) ;;; TESTS communicating with other routines on the CADR simulator, assumed to ;;; be at CHAOS address #o401 #| ;;; CADR only tests ;;; this is in >jao>chaos.lisp.5 (defun count-server () (let ((conn (chaos:listen "COUNT"))) (chaos:accept conn) (do ((pkt (chaos:get-next-pkt conn) (chaos:get-next-pkt conn)) (count 0 (1+ count))) ((neq (chaos:state conn) 'chaos:open-state)) (chaos:return-pkt pkt) (chaos:send-string conn (format nil "COUNT ~D" count))))) (defun use-count () (let ((conn (chaos:connect 401 "COUNT"))) (if (stringp conn) conn (dotimes (i 3) (chaos:send-string conn (format nil "HI ~D" i)) (let ((pkt (chaos:get-next-pkt conn))) (format t "~A~%" (chaos:pkt-string pkt)) (chaos:return-pkt pkt))) (chaos:close conn)))) (defun test-count () (setf *proc* (process-run-function "COUNT SERVER" #'count-server)) (use-count)) ;;; note, ctrl-option-Z is evaluate and quit (test-count) ; 391:084738 RFC to (1 1:0,0) from (1 1:78,80) pkn 0 ackn 0 len 28 ; 00000000 00 01 05 00 01 01 00 00 01 01 4e 50 00 00 00 00 ..........NP.... ; 00000010 43 4f 55 4e 54 53 01 01 01 01 bb b9 xx xx xx xx COUNTS......xxxx ; 0:341923 OPN to (1 1:78,80) from (1 1:205,79) pkn 1 ackn 0 len 26 ; 00000000 00 02 04 00 01 01 4e 50 01 01 cd 4f 01 00 00 00 ......NP...O.... ; 00000010 00 00 0d 00 01 01 01 01 ce 59 xx xx xx xx xx xx .........Yxxxxxx ; 0:273637 STS to (1 1:205,79) from (1 1:78,80) pkn 1 ackn 1 len 26 ; 00000000 00 07 04 00 01 01 cd 4f 01 01 4e 50 01 00 01 00 .......O..NP.... ; 00000010 01 00 0d 00 01 01 01 01 cc 54 xx xx xx xx xx xx .........Txxxxxx ; 0:481092 80 to (1 1:205,79) from (1 1:78,80) pkn 1 ackn 1 len 26 ; 00000000 00 80 04 00 01 01 cd 4f 01 01 4e 50 01 00 01 00 .......O..NP.... ; 00000010 48 49 20 30 01 01 01 01 71 62 xx xx xx xx xx xx HI 0....qbxxxxxx ; 0:425478 SNS to (1 1:205,79) from (1 1:78,80) pkn 1 ackn 1 len 22 ; 00000000 00 06 00 00 01 01 cd 4f 01 01 4e 50 01 00 01 00 .......O..NP.... ; 00000010 01 01 01 01 de 55 xx xx xx xx xx xx xx xx xx xx .....Uxxxxxxxxxx ; 0:001293 STS to (1 1:78,80) from (1 1:205,79) pkn 1 ackn 1 len 26 ; 00000000 00 07 04 00 01 01 4e 50 01 01 cd 4f 01 00 01 00 ......NP...O.... ; 00000010 01 00 0d 00 01 01 01 01 cc 54 xx xx xx xx xx xx .........Txxxxxx ; 0:142775 80 to (1 1:78,80) from (1 1:205,79) pkn 2 ackn 1 len 30 ; 00000000 00 80 07 00 01 01 4e 50 01 01 cd 4f 02 00 01 00 ......NP...O.... ; 00000010 43 4f 55 4e 54 20 30 55 01 01 01 01 b8 c8 xx xx COUNT 0U......xx ; 0:425938 STS to (1 1:78,80) from (1 1:205,79) pkn 1 ackn 1 len 26 ; 00000000 00 07 04 00 01 01 4e 50 01 01 cd 4f 01 00 01 00 ......NP...O.... ; 00000010 01 00 0d 00 01 01 01 01 cc 54 xx xx xx xx xx xx .........Txxxxxx ; 0:099043 STS to (1 1:205,79) from (1 1:78,80) pkn 1 ackn 2 len 26 ; 00000000 00 07 04 00 01 01 cd 4f 01 01 4e 50 01 00 02 00 .......O..NP.... ; 00000010 02 00 0d 00 01 01 01 01 ca 54 xx xx xx xx xx xx .........Txxxxxx ; 0:363212 80 to (1 1:205,79) from (1 1:78,80) pkn 2 ackn 2 len 26 ; 00000000 00 80 04 00 01 01 cd 4f 01 01 4e 50 02 00 02 00 .......O..NP.... ; 00000010 48 49 20 31 01 01 01 01 6f 61 xx xx xx xx xx xx HI 1....oaxxxxxx ; 0:388059 STS to (1 1:78,80) from (1 1:205,79) pkn 2 ackn 2 len 26 ; 00000000 00 07 04 00 01 01 4e 50 01 01 cd 4f 02 00 02 00 ......NP...O.... ; 00000010 02 00 0d 00 01 01 01 01 c9 54 xx xx xx xx xx xx .........Txxxxxx ; 0:172022 80 to (1 1:78,80) from (1 1:205,79) pkn 3 ackn 2 len 30 ; 00000000 00 80 07 00 01 01 4e 50 01 01 cd 4f 03 00 02 00 ......NP...O.... ; 00000010 43 4f 55 4e 54 20 31 55 01 01 01 01 b5 c8 xx xx COUNT 1U......xx ; 0:430707 STS to (1 1:205,79) from (1 1:78,80) pkn 3 ackn 3 len 26 ; 00000000 00 07 04 00 01 01 cd 4f 01 01 4e 50 03 00 03 00 .......O..NP.... ; 00000010 03 00 0d 00 01 01 01 01 c6 54 xx xx xx xx xx xx .........Txxxxxx ; 0:001157 80 to (1 1:205,79) from (1 1:78,80) pkn 3 ackn 3 len 26 ; 00000000 00 80 04 00 01 01 cd 4f 01 01 4e 50 03 00 03 00 .......O..NP.... ; 00000010 48 49 20 32 01 01 01 01 6d 60 xx xx xx xx xx xx HI 2....m`xxxxxx ; 0:455537 STS to (1 1:78,80) from (1 1:205,79) pkn 3 ackn 3 len 26 ; 00000000 00 07 04 00 01 01 4e 50 01 01 cd 4f 03 00 03 00 ......NP...O.... ; 00000010 03 00 0d 00 01 01 01 01 c6 54 xx xx xx xx xx xx .........Txxxxxx ; 0:127586 80 to (1 1:78,80) from (1 1:205,79) pkn 4 ackn 3 len 30 ; 00000000 00 80 07 00 01 01 4e 50 01 01 cd 4f 04 00 03 00 ......NP...O.... ; 00000010 43 4f 55 4e 54 20 32 55 01 01 01 01 b2 c8 xx xx COUNT 2U......xx ; 0:292621 STS to (1 1:205,79) from (1 1:78,80) pkn 3 ackn 4 len 26 ; 00000000 00 07 04 00 01 01 cd 4f 01 01 4e 50 03 00 04 00 .......O..NP.... ; 00000010 04 00 0d 00 01 01 01 01 c4 54 xx xx xx xx xx xx .........Txxxxxx ; 0:192391 CLS to (1 1:205,79) from (1 1:78,80) pkn 0 ackn 0 len 22 ; 00000000 00 03 00 00 01 01 cd 4f 01 01 4e 50 00 00 00 00 .......O..NP.... ; 00000010 01 01 01 01 e0 58 xx xx xx xx xx xx xx xx xx xx .....Xxxxxxxxxxx ; 0:456314 LOS to (1 1:78,80) from (1 1:205,79) pkn 3 ackn 4 len 42 ; 00000000 00 09 13 00 01 01 4e 50 01 01 cd 4f 03 00 04 00 ......NP...O.... ; 00000010 43 6f 6e 6e 65 63 74 69 6f 6e 20 6e 6f 74 20 6f Connection not o ; 00000020 70 65 6e 00 01 01 01 01 3c 82 xx xx xx xx xx xx pen.....<.xxxxxx |# #| ;;; openmcl equivalent ;;; (defvar *test-proc*) (defun count-server () (let ((conn (chaos:listen "COUNT"))) (chaos:accept conn) (do ((pkt (chaos::get-next-pkt conn) (chaos::get-next-pkt conn)) (count 0 (1+ count))) ((neq (chaos:state conn) :open)) (chaos:send-string conn (format nil "COUNT ~D" count))))) (defun count-hostile () (chaos:reject (chaos:listen "COUNT") "Go away. I don't feel like counting today")) (defun use-count (&optional (addr chaos:*chaos-address*)) (let ((conn (chaos:connect addr "COUNT"))) (if (stringp conn) conn (progn (dotimes (i 3) (chaos:send-string conn (format nil "HI ~D" i)) (let ((pkt (chaos::get-next-pkt conn))) (format t "~A~%" (chaos:data-string pkt)))) (chaos:close conn))))) (defun test-count () (setf *test-proc* (ccl:process-run-function "COUNT SERVER" #'count-server)) (use-count)) (test-count) ;;; to count-server by hand ;;; (setf *conn* (chaos:accept (chaos:listen "COUNT"))) ;;; in separate listener ;;; |# #| ;;; on CADR side ;;; (defun cadr-side () (let ((conn (chaos:listen "CADRTEST")) (chaos:accept conn)))) (cadr-side) ;;; on openmcl side (chaos::connect (chaos::short-address #o401) "CADRTEST") |# ;;; Retransmission and probing ;;; ;;; ChaosNET depends on retransmission and probing to ensure ;;; reliability in the face of possible packet loss. This is ;;; probably unneeded for UNIX domain sockets, but will be needed ;;; in order to work over UDP. ;;; ;;; There are two (or more?) possible reasons to send out packets unprompted ;;; ;;; 1) For each connection, every 1/2 second, retransmit any controlled ;;; packets that have not been receipted by the other end, unless ;;; they were transmitted very recently, say, in the last 1/30th ;;; of a second. ;;; Packets that have not been receipted are those on the send-pkts ;;; list, because #'SEND-PKT puts them on, and #'RECEIPT is supposed to ;;; remove the receipted ones. ;;; ;;; *actually, the LispM code seems to use a 1 second age* (defconstant +retransmit-interval+ (* internal-time-units-per-second 1/2)) (defconstant +retransmit-ticks+ (* ccl:*ticks-per-second* 3/8)) (defconstant +fresh-packet-interval+ (* internal-time-units-per-second 1/30)) (defmethod packet-retransmit-p ((cpkt connection-packet) internal-time) "Assuming CPKT is a non-receipted packet, returns true if CPKT is due to be retransmitted." (>= internal-time (+ (time-transmitted cpkt) +retransmit-interval+))) (defmethod retransmit-pkts ((conn connection) internal-time) (labels ((retransmit-pkt (cpkt) ;;; TODO? make sure this is atomic? (write-packet (packet cpkt)) (incf (transmission-count cpkt)) (setf (time-transmitted cpkt) internal-time)) (already-receipted (cpkt) (let ((pkt-num (packet-number (packet cpkt)))) (or (not (pktnum-< (send-packet-acked conn) pkt-num)) (not (pktnum-< (send-packet-receipted conn) pkt-num)))))) (when (member (state conn) '(:open :rfc-sent)) (ccl:with-lock-grabbed ((send-packet-lock conn)) (let ((new-send-pkts (delete-if #'already-receipted (send-pkts conn)))) (mapcar #'(lambda (cpkt) (when (packet-retransmit-p cpkt internal-time) (retransmit-pkt cpkt))) new-send-pkts) (setf (send-pkts conn) new-send-pkts)))))) (defun retransmit () (let ((internal-time (get-internal-real-time))) (ccl:with-lock-grabbed (*connection-hash-lock*) (map-connections #'(lambda (conn) (retransmit-pkts conn internal-time)))))) ;;; ;;; 2) For each open connection, every five seconds, we send an SNS packet ;;; if there are unacknowledged packets (a non-empty window). The idea ;;; is to provoke a response, at least of an STS. If no packets are ;;; received for 1 1/2 minutes, the connection is declared broken. ;;; ;;; *actually, the LispM code seems to only probe every minute, although ;;; it checks for the necessity to probe every 10 seconds.* (defconstant +probe-interval+ (* internal-time-units-per-second 5)) (defconstant +host-down-interval+ (* internal-time-units-per-second 90)) (defmethod probe-needed-p ((conn connection) internal-time) "Note, assumes it is called only approximately every +probe-interval+; a time-last-probe slot is probably the best way to handle this." (and (member (state conn) '(:open :rfc-sent)) (>= internal-time (+ (time-last-received conn) +probe-interval+)) (< (window-available conn) (foreign-window-size conn)))) (defmethod probe-conn ((conn connection) internal-time) (let ((pkt (make-instance 'packet))) (setf (opcode pkt) +sns-op+ (data-byte-count pkt) 0) ;; (ccl::with-read-lock ((count-lock conn)) ; transmit-pkt grabs this (when (probe-needed-p conn internal-time) (transmit-pkt conn pkt t)))) (defun probe () "Send SNS probe on all connections requiring it" (ccl::with-lock-grabbed (*connection-hash-lock*) (let ((internal-time (get-internal-real-time))) (map-connections #'(lambda (conn) (probe-conn conn internal-time)))))) (defun retransmit-process () (let ((time (get-internal-real-time))) (do ((last-probe-time time) (last-retransmit-time time)) () (setf time (get-internal-real-time)) (when (> time (+ last-probe-time +probe-interval+)) (setf last-probe-time time) (probe)) (when (> time (+ last-retransmit-time +retransmit-interval+)) (setf last-retransmit-time time) (retransmit)) (ccl::process-wait-with-timeout "Chaos Retransmit Sleep" +retransmit-ticks+ #'(lambda () nil))))) ; debug OpenMCL crash? (defclass chaos:stream () ((connection :accessor connection :initarg :connection) (out-packet :accessor out-packet :initform nil) (out-byte-index :accessor out-byte-index :initform 0 :type 'integer) (in-packet :accessor in-packet :initform nil) (in-byte-index :accessor in-byte-index :initform 0 :type 'integer))) (defmethod create-stream ((conn connection)) (make-instance 'chaos:stream :connection conn)) (defmethod input-byte ((str chaos:stream) &optional no-hang) "Returns next byte in the stream, or :EOF if the EOF packet has been received, or NIL if no-hang is non-nil and no byte is available." (with-accessors ((in-pkt in-packet) (in-b in-byte-index)) str (cond ((eq in-pkt :eof) :eof) ((and in-pkt (< in-b (data-byte-count in-pkt))) (prog1 (aref (data-bytes in-pkt) in-b) (incf in-b))) (t (setf in-pkt (get-next-pkt (connection str) no-hang) in-b 0) (when in-pkt (let ((opc (opcode in-pkt))) (cond ((or (= opc +cls-op+) (= opc +eof-op+)) (setf in-pkt :eof)) ((= opc +los-op+) (error "Received LOS packet ~S." (data-string in-pkt))) ((>= opc +dat-op+) (prog1 (aref (data-bytes in-pkt) in-b) (incf in-b))) (t (error "Received packet opcode #o~O" opc))))))))) (defmethod chaos:force-output ((str chaos:stream)) (when (and (out-packet str) (> (out-byte-index str) 0)) (setf (data-byte-count (out-packet str)) (min (out-byte-index str) +max-data-byte-count+)) (send-pkt (connection str) (out-packet str)) (setf (out-byte-index str) 0))) (defmethod output-byte (byte (str chaos:stream)) (unless (out-packet str) (setf (out-packet str) (make-instance 'packet) (opcode (out-packet str)) +dat-op+)) (setf (aref (data-bytes (out-packet str)) (out-byte-index str)) byte) (incf (out-byte-index str)) (when (>= (out-byte-index str) +max-data-byte-count+) (chaos:force-output str) (setf (out-byte-index str) 0))) (defmethod chaos:close ((str chaos:stream) &optional reason) "Close the stream; does not flush output." (chaos:close (connection str) reason)) (defmethod send-eof ((str chaos:stream)) (chaos:force-output str) (transmit-eof (connection str)) (chaos:finish (connection str))) (defmethod chaos:eof ((str chaos:stream)) (eq (in-packet str) :eof)) (defmethod chaos:finish ((str chaos:stream) &optional (whostate "Chaos Finish")) (chaos:finish (connection str) whostate)) (defmethod clear-eof ((str chaos:stream)) "Clears the input EOF condition of STR if present." (when (eq (in-packet str) :eof) (setf (in-packet str) nil))) #| ;;; attempt at a SEND message receiver ;;; ;;; try (qsend "jao@402") and ctrl-C seems a good-enough substitute for ;;; ;;; or just (qsend "jao@402" "your message here.") ;;; ;;; next up: provide a gateway to Jabber: translate the jao@402 to a suitable ;;; jabber ID (table lookup?) and use cl-xmpp (defun receive-qsend () (let* ((conn (chaos:accept (chaos:listen "SEND"))) (str (chaos:create-stream conn)) (arr (make-array 1000 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) (do ((b (chaos:input-byte str) (chaos:input-byte str))) ((not (integerp b)) (prog1 arr (chaos:close str))) (vector-push-extend b arr)))) ;; try by hand (defvar *conn*) (setf *conn* (chaos:accept (chaos:listen "SEND"))) (setf *pkt1* (chaos:get-next-pkt *conn*)) (setf *pkt2* (chaos:get-next-pkt *conn*)) (setf *pkt3* (chaos:get-next-pkt *conn*)) (setf *str* (chaos::create-stream *conn*)) (setf *b* (chaos::input-byte *str*)) (defvar *str*) (setf *str* (chaos:create-stream (chaos:accept (chaos:listen "SEND")))) |# (defmethod read-to-eof ((str chaos:stream)) (let ((s (make-string-output-stream))) (do ((b (chaos:input-byte str) (chaos:input-byte str))) ((not (integerp b)) (let ((result (get-output-stream-string s))) (if (eql b :eof) (if (zerop (length result)) :eof result) result))) (write-char (lm-code-char b) s)))) (defmethod read-lm-line ((str chaos:stream)) "Return a string, translated from Lisp Machine encoding, ending in #o215 (Lisp Machine Return), excluding the terminating code. Also ends the string if an EOF is read; returns :EOF if EOF is the first character read." (let ((s (make-string-output-stream))) (do ((b (chaos:input-byte str) (chaos:input-byte str))) ((or (not (integerp b)) (= b #o215)) (let ((result (get-output-stream-string s))) (if (eql b :eof) (if (zerop (length result)) :eof result) result))) (write-char (lm-code-char b) s)))) (defmethod write-lm-line ((line string) (str chaos:stream)) (map nil (lambda (c) (chaos:output-byte (lm-char-code c) str)) line) (chaos:output-byte #o215 str)) #|| ;;;; test stream functionality ;;;; (defvar *conn*) (defvar *str*) (setf *conn* (chaos:accept (chaos:listen "TEST"))) (setf *str* (chaos:create-stream *conn*)) ; on CADR ; (setf *conn* (chaos:connect 402 "TEST")) ; (setf *str* (chaos:stream *conn*)) ; (format *str* "this is a line~%") ; (funcall *str* ':force-output) ;; sends data packet (chaos:read-lm-line *str*) --> "this is a line" (chaos:write-lm-line "this is a response" *str*) (chaos:force-output *str*) (chaos:read-to-eof *str*) ; (funcall *str* ':line-in) ; (format *str* "this is a pair~%of lines~%") ; (funcall *str* ':eof) ||#