;;; -*- Mode:LISP; Package:CHAOS; Base:10; Readtable:CL -*-
;;;	** (c) Copyright 1981 Massachusetts Institute of Technology **
;;;
;;; This is SYS: NETWORK; CHAOS; CHUSE
;;; Very high-level CHAOSnet functions.
;;; The NCP and low level functions in SYS: NETWORK; CHAOS; CHSNCP

;;; This returns a connection to frob, and the host name
(defun establish-connection (real-address contact-name timeout window-size &aux conn host-name)
  (assure-enabled)
  (setq conn (open-connection real-address contact-name window-size))
  (setq host-name
	(or (si:get-host-from-address real-address :chaos)
	    real-address))
  (let ((wait-completed nil))
    (unwind-protect
	(progn
	  (wait conn 'rfc-sent-state timeout
		(format nil "Net Connect: ~A"
			(if (typep host-name 'instance)
			    (send host-name :short-name)
			  host-name)))
	  (setq wait-completed t))
      (unless wait-completed
	(remove-conn conn)))
    (values (and wait-completed conn) host-name)))

;;; This does a full "ICP": it sends an RFC, waits for a reply or timeout,
;;; and returns a string to get an error, or else the CONN to indicate that
;;; the foreign host sent an OPN and we are connected.
;;; The first argument gets parsed as an address.
(DEFUN CONNECT (ADDRESS CONTACT-NAME &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE)
					       (TIMEOUT (* 10. 60.))
			      &AUX CONN REAL-ADDRESS HOST-NAME)
  "Establish a chaosnet connection and return the connection object.
ADDRESS is a host name or number.  CONTACT-NAME is a string containing
the contact name and optional additional data for the other host.
WINDOW-SIZE is the number of packets that can be in transit from
the other side, on this connection.
TIMEOUT is how long to wait before giving up (in 60'ths of a second).

If the connection fails, an error is signaled."
  (DO-FOREVER
    (CATCH-ERROR-RESTART-EXPLICIT-IF T (SYS:REMOTE-NETWORK-ERROR
					 :RETRY-CONNECTION "Try the connection again.")
      (COND ((NULL (SETQ REAL-ADDRESS (ADDRESS-PARSE ADDRESS)))
	     (FERROR 'SYS:UNKNOWN-ADDRESS "~S is not a valid Chaosnet address." ADDRESS))
	    (T
	     (multiple-value (conn host-name)
	       (establish-connection real-address contact-name timeout window-size))
	     (CASE (STATE CONN)
	       (OPEN-STATE (RETURN CONN))
	       (RFC-SENT-STATE (CLOSE-CONN CONN)
			       (funcall *chaos-stream* :flush-address (conn-foreign-address conn))
			       (FERROR 'SYS:HOST-NOT-RESPONDING-DURING-CONNECTION
				       "Host ~1@*~A not responding."
				       CONN HOST-NAME))
	       (ANSWERED-STATE (CLOSE-CONN CONN)
			       (FERROR 'SYS:CONNECTION-ERROR-1
				       "Received an ANS instead of an OPN."
				       CONN))
	       (CLS-RECEIVED-STATE
		(LET* ((PKT (GET-NEXT-PKT CONN))
		       (STRING (STRING-APPEND (PKT-STRING PKT))))
		  (RETURN-PKT PKT)
		  (CLOSE-CONN CONN)
		  (IF (EQUAL STRING "")
		      (FERROR 'SYS:CONNECTION-REFUSED
			      "Connection to ~1@*~A rejected without explanation."
			      CONN HOST-NAME)
		    (FERROR 'SYS:CONNECTION-REFUSED	
			    "Connection to ~1@*~A refused: ~A."
			    CONN HOST-NAME STRING))))
	       (OTHERWISE (UNWIND-PROTECT
			      (FERROR 'SYS:CONNECTION-ERROR-1
				      "Bad state in ~S: ~A~@[, ~A~]"
				      CONN
				      (STATE CONN) 
				      (AND (READ-PKTS CONN) (PKT-STRING (READ-PKTS CONN))))
			    (REMOVE-CONN CONN)))))))
    ;; The second time, wait a long time.
    (SETQ TIMEOUT (* 2 TIMEOUT))))

;;; Takes anything anyone might use as a ChaosNet address, and tries to return
;;; the corresponding host number.  If it fails, returns NIL.
(DEFUN ADDRESS-PARSE (ADDRESS &AUX HOST)
  "Coerce the argument to a chaosnet address.
The argument can be a host name or host object, or an address."
  (DECLARE (VALUES ADDRESS HOST-OBJECT))
  (CONDITION-CASE (ERROR)
      (LET ((ADDRESS (COND ((INTEGERP ADDRESS)
			    ADDRESS)
			   ((AND (TYPEP ADDRESS 'INSTANCE)
				 (SEND (SETQ HOST ADDRESS) :SEND-IF-HANDLES :network-ADDRESS :chaos)))
			   ((AND (SETQ HOST (SI:PARSE-HOST ADDRESS T))
				 (SEND HOST :network-address :CHAOS)))
			   ((AND (STRINGP ADDRESS)
				 (PARSE-NUMBER ADDRESS 0 NIL 8))))))
	(IF ADDRESS (VALUES ADDRESS (OR HOST (SI:GET-HOST-FROM-ADDRESS ADDRESS :CHAOS)))))
    (SYS:UNCLAIMED-MESSAGE NIL)))

;;; This is used to perform a "simple connection".  An RFC is sent to the
;;; specified address, expecting an ANS.  Returns a string if there was an
;;; error, in which case the string is an ASCII explanation.  Otherwise
;;; returns the ANS.  When you are done perusing the ANS, RETURN-PKT the PKT.
(DEFUN SIMPLE (ADDRESS CONTACT-NAME &OPTIONAL (TIMEOUT (* 10. 60.))
	       &AUX CONN REAL-ADDRESS HOST-NAME)
  "Send a message to CONTACT-NAME at ADDRESS, expecting one ANS packet in return.
No connection is established; if the other host tries to create a connection,
it is considered an error.
If successful, the ANS packet object is returned.
Otherwise, a string describing the reasons for failure is returned.
TIMEOUT is how long to wait before giving up, in 60'ths of a second."
  (DO-FOREVER
    (CATCH-ERROR-RESTART-EXPLICIT-IF T (SYS:REMOTE-NETWORK-ERROR :RETRY-CONNECTION
					 "Try the transaction again.")
      (COND ((NULL (SETQ REAL-ADDRESS (ADDRESS-PARSE ADDRESS)))
	     (FERROR 'SYS:UNKNOWN-ADDRESS "~S is not a valid Chaosnet address." ADDRESS))
	    (T (multiple-value (conn host-name)
		 (establish-connection real-address contact-name timeout 5))
	       (CASE (STATE CONN)
		 (RFC-SENT-STATE
		  (REMOVE-CONN CONN)
		  (funcall *chaos-stream* :flush-address (conn-foreign-address conn))
		  (FERROR 'SYS:HOST-NOT-RESPONDING-DURING-CONNECTION
			  "Host ~1@*~A not responding."
			  CONN HOST-NAME))
		 (CLS-RECEIVED-STATE
		  (LET* ((PKT (GET-NEXT-PKT CONN))
			 (STRING (STRING-APPEND (PKT-STRING PKT))))
		    (RETURN-PKT PKT)
		    (REMOVE-CONN CONN)
		    (IF (EQUAL STRING "")
			(FERROR 'SYS:CONNECTION-REFUSED
				"Simple transaction to ~1@*~S rejected without explanation."
				CONN HOST-NAME)
		        (FERROR 'SYS:CONNECTION-REFUSED
				"Simple transaction to ~1@*~S refused: ~A."
				CONN HOST-NAME STRING))))
		 (OPEN-STATE
		  (CLOSE-CONN CONN "I expected an ANS, not an OPN.")
		  (FERROR 'SYS:CONNECTION-ERROR-1
			  "Received an OPN instead of an ANS."
			  CONN))
		 (ANSWERED-STATE
		  (RETURN (PROG1 (GET-NEXT-PKT CONN)
				 (CLOSE-CONN CONN))))
		 (OTHERWISE (UNWIND-PROTECT
			      (FERROR 'SYS:CONNECTION-ERROR-1
				      "Bad state in ~S: ~A~@[, ~A~]"
				      CONN
				      (STATE CONN) 
				      (AND (READ-PKTS CONN) (PKT-STRING (READ-PKTS CONN))))
			      (REMOVE-CONN CONN)))))))
    (SETQ TIMEOUT (* 2 TIMEOUT))))

(DEFMACRO VALID-ADDRESS? (ADDRESS)
  `(TYPEP ,ADDRESS '(INTEGER 0 #o177777)))

;;;; USER FUNCTIONS: Functions for the user side of a connection.

;;; This is called as the first step in opening a connection.  Note the
;;; CONNECT function, which is a higher-level frob (like NETWRK's ICP routine)
;;; which you may want to use instead.
;;;   The first arg is the address of the foreign host.  Next is the contact name.
;;; Optionally following are the one-way flag and window size.
(DEFUN OPEN-CONNECTION (ADDRESS CONTACT-NAME &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE)
		      &AUX PKT CONN)
    (CHECK-TYPE ADDRESS (SATISFIES VALID-ADDRESS?) "an address")
    (CHECK-ARG CONTACT-NAME
               (AND (STRINGP CONTACT-NAME) ( (LENGTH CONTACT-NAME) MAX-DATA-BYTES-PER-PKT))
               "a string")
    (CHECK-TYPE WINDOW-SIZE NUMBER "a number")
    (SETQ CONN (MAKE-CONNECTION))
    (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN WINDOW-SIZE MAXIMUM-WINDOW-SIZE)))
    (SETF (FOREIGN-ADDRESS CONN) ADDRESS)
    (SETF (GETF (CONN-PLIST CONN) 'RFC-CONTACT-NAME) CONTACT-NAME)

    (UNWIND-PROTECT
      (PROGN
	(SETQ PKT (ALLOCATE-PKT))
	(SETF (PKT-OPCODE PKT) RFC-OP)
	(SET-PKT-STRING PKT CONTACT-NAME)
	(SETF (PKT-LINK PKT) NIL)
	(WITHOUT-INTERRUPTS
	  (SETF (WINDOW-AVAILABLE CONN) 1)
	  (SETF (TIME-LAST-RECEIVED CONN) (zl:TIME))
	  (SETF (STATE CONN) 'RFC-SENT-STATE))
	(TRANSMIT-NORMAL-PKT CONN PKT (PKT-NUM-SENT CONN))
	;; Must not put on lists before calling TRANSMIT-NORMAL-PKT, which fills in
	;; important information    
	(WITHOUT-INTERRUPTS
	  (SETF (SEND-PKTS CONN) PKT)
	  (SETF (SEND-PKTS-LAST CONN) PKT)
	  (SETF (SEND-PKTS-LENGTH CONN) 1) 
	  (SETQ RETRANSMISSION-NEEDED T)
	  (SETQ PKT NIL)))
      (AND PKT (FREE-PKT PKT)))
    CONN)

#| This stuff can't work yet -- RpK
;;; Open up a connection for use with foreign protocols
(DEFUN OPEN-FOREIGN-CONNECTION (FOREIGN-HOST FOREIGN-INDEX
				&OPTIONAL (PKT-ALLOCATION 10.) DISTINGUISHED-PORT
				&AUX CONN)
  (CHECK-TYPE FOREIGN-HOST (SATISFIES VALID-ADDRESS?) "an address")
  (SETQ CONN (MAKE-CONNECTION))
  (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN PKT-ALLOCATION MAXIMUM-WINDOW-SIZE)))
  (SETF (FOREIGN-ADDRESS CONN) FOREIGN-HOST)
  (SETF (FOREIGN-INDEX-NUM CONN) FOREIGN-INDEX)
  (SETF (STATE CONN) 'FOREIGN-STATE)
  (WHEN DISTINGUISHED-PORT
    (SETF (AREF INDEX-CONN (LDB MAXIMUM-INDEX-LOG-2-MINUS-1 (LOCAL-INDEX-NUM CONN))) NIL)
    (SETF (LOCAL-INDEX-NUM CONN) DISTINGUISHED-PORT)
    (PUSH (CONS DISTINGUISHED-PORT CONN) DISTINGUISHED-PORT-CONN-TABLE))
  CONN)

(DEFVAR *ALL-SUBNET-BIT-MAP* (MAKE-ARRAY 32. :element-type '(mod #o400) :INITIAL-ELEMENT #o377))

(DEFUN SUBNET-BIT-MAP (SUBNETS)
  "SUBNETS may be a list of subnet numbers, or the symbol :ALL"
  (DECLARE (VALUES BIT-MAP BIT-MAP-LENGTH))
  (COND ((EQ SUBNETS :ALL) (VALUES *ALL-SUBNET-BIT-MAP* 32.))
	((NULL SUBNETS) (VALUES (MAKE-ARRAY 4. :ELEMENT-TYPE 'string-char :INITIAL-ELEMENT 0) 4))
	(T
	 (LET* ((BIT-MAP-LENGTH (* (CEILING (CEILING (1+ (APPLY #'MAX SUBNETS)) 8.) 4) 4))
		(BIT-MAP (MAKE-ARRAY BIT-MAP-LENGTH :element-TYPE '(mod #o400) :INITIAL-ELEMENT 0)))
	   (DOLIST (SUBNET SUBNETS)
	     (MULTIPLE-VALUE-BIND (BYTE BIT) (TRUNCATE SUBNET 8)
	       (SETF (AREF BIT-MAP BYTE) (LOGIOR (AREF BIT-MAP BYTE) (LSH 1 BIT)))))
	   (VALUES BIT-MAP BIT-MAP-LENGTH)))))
  
(DEFUN OPEN-BROADCAST-CONNECTION (SUBNETS CONTACT-NAME &OPTIONAL (PKT-ALLOCATION 10.)
				  &AUX SUBNET-BIT-MAP SUBNET-BIT-MAP-LENGTH)
  "Broadcast a service request from CONTACT-NAME over certain subnets.
PKT-ALLOCATION is the buffering size for unread requests as they come over the net.
The connection returned is in the CHAOS:BROADCAST-SENT-STATE."
  (MULTIPLE-VALUE (SUBNET-BIT-MAP SUBNET-BIT-MAP-LENGTH) (SUBNET-BIT-MAP SUBNETS))
  (LET ((CONN (MAKE-CONNECTION)))
    (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN PKT-ALLOCATION MAXIMUM-WINDOW-SIZE)))
    (SETF (FOREIGN-ADDRESS CONN) 0) ; seems ok
    ; (SETF (FOREIGN-INDEX-NUM CONN) FOREIGN-INDEX) ; not sure about this
    (LET ((PKT NIL))
      (UNWIND-PROTECT
	  (PROGN
	    (SETQ PKT (ALLOCATE-PKT))
	    (SETF (PKT-ACK-NUM PKT) SUBNET-BIT-MAP-LENGTH)
	    (SETF (PKT-OPCODE PKT) BRD-OP)
	    (SETF (PKT-LINK PKT) NIL)
	    (SETF (PKT-DEST-ADDRESS PKT) 0)
	    (SETF (PKT-DEST-INDEX-NUM PKT) 0)
	    (SETF (PKT-SOURCE-ADDRESS PKT) MY-ADDRESS)
	    (SETF (PKT-SOURCE-INDEX-NUM PKT) (LOCAL-INDEX-NUM CONN))
	    (SETF (GETF (CONN-PLIST CONN) 'BROADCAST-CONNECTION) T)
	    (SETF (GETF (CONN-PLIST CONN) 'SUBNET-BIT-MAP) SUBNET-BIT-MAP)
	    (SETF (GETF (CONN-PLIST CONN) 'SUBNET-BIT-MAP-LENGTH) SUBNET-BIT-MAP-LENGTH)
	    (SETF (GETF (CONN-PLIST CONN) 'CONTACT-NAME) CONTACT-NAME)
	    (SET-PKT-STRING PKT SUBNET-BIT-MAP CONTACT-NAME)
	    (WITHOUT-INTERRUPTS
	      (SETF (WINDOW-AVAILABLE CONN) 1)
	      (SETF (TIME-LAST-RECEIVED CONN) (zl:TIME))
	      (SETF (STATE CONN) 'BROADCAST-SENT-STATE))
	    (TRANSMIT-PKT PKT ()))
	(AND PKT (FREE-PKT PKT)))
    CONN)))

(DEFMACRO ASSURE-BROADCAST-CONNECTION (CONN)
  `(IF (NOT (GETF (CONN-PLIST ,CONN) 'BROADCAST-CONNECTION))
       (FERROR 'SYS:LOCAL-NETWORK-ERROR
	       :FORMAT-STRING "~A was not opened in broadcast mode"
	       :FORMAT-ARGS (LIST ,CONN))))

(DEFUN RETRANSMIT-BRD-PACKET (CONN)
  "Send out another request for service, if CONN was opened in broadcast mode."
  (ASSURE-BROADCAST-CONNECTION CONN)
  (LET ((PKT (ALLOCATE-PKT))
	(SUBNET-BIT-MAP-LENGTH (GET (LOCF (CONN-PLIST CONN)) 'SUBNET-BIT-MAP-LENGTH)))
    (UNWIND-PROTECT
	(PROGN
	  (SETF (PKT-ACK-NUM PKT) SUBNET-BIT-MAP-LENGTH)
	  (SETF (PKT-OPCODE PKT) BRD-OP)
	  (SETF (PKT-DEST-ADDRESS PKT) 0)
	  (SETF (PKT-DEST-INDEX-NUM PKT) 0)
	  (SETF (PKT-SOURCE-ADDRESS PKT) MY-ADDRESS)
	  (SETF (PKT-SOURCE-INDEX-NUM PKT) (LOCAL-INDEX-NUM CONN))
	  (SET-PKT-STRING PKT (GET (LOCF (CONN-PLIST CONN)) 'SUBNET-BIT-MAP)
			  (GET (LOCF (CONN-PLIST CONN)) 'CONTACT-NAME))
	  (TRANSMIT-PKT PKT ()))
      (FREE-PKT PKT))))

(DEFUN READ-BROADCAST-PKT (CONN &KEY NO-HANG-P (RESET-STATE-P :ANS) (WHOSTATE "BRD In"))
  "Returns a PKT or NIL, like GET-NEXT-PKT.
This function will do nasty things if not called on a broadcast CONN.
RESET-STATE-P can be
 :ANS only if an ANS was received
 :ALWAYS if any type of packet was received
 NIL never"
  (ASSURE-BROADCAST-CONNECTION CONN)
  (LET ((PKT (GET-NEXT-PKT CONN NO-HANG-P WHOSTATE)))
    (UNLESS (NULL PKT)
      (IF (OR (EQ RESET-STATE-P :ALWAYS)
	      (AND (EQ (STATE CONN) 'ANSWERED-STATE) (EQ RESET-STATE-P :ANS)))
	  (SETF (STATE CONN) 'BROADCAST-SEND-STATE))
      PKT)))
|#  

;;;; SERVER FUNCTIONS: Functions used by the server side of a connection only.

(DEFUN LISTEN (CONTACT-NAME &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE) (WAIT-FOR-RFC T)
		     &AUX CONN)
    "Listen for an incoming RFC to CONTACT-NAME.
Returns the connection-object, ready to have CHAOS:ACCEPT,
CHAOS:REJECT, CHAOS:ANSWER, or CHAOS:FORWARD done to it.
A server function on SERVER-ALIST can call LISTEN to respond to
the request which caused the server to be run.
If WAIT-FOR-RFC is NIL, doesn't wait for the RFC to arrive, just sets up a queue.
WINDOW-SIZE specifies how many packets can be in transit at once from the
other side of the connection to this one, once the connection is established."
    (CHECK-TYPE CONTACT-NAME STRING)
    (CHECK-TYPE WINDOW-SIZE NUMBER)
    ;; Make a connection.  If table full, wait a little while and try again.
    (DO-FOREVER
      (CONDITION-CASE ()
          (SETQ CONN (MAKE-CONNECTION))
	(SYS:NETWORK-RESOURCES-EXHAUSTED
	  (PROCESS-SLEEP 30.))
	(:NO-ERROR (RETURN))))
    (SETF (GETF (CONN-PLIST CONN) 'LISTEN-CONTACT-NAME) CONTACT-NAME)
    (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN WINDOW-SIZE MAXIMUM-WINDOW-SIZE)))
    (PROG LISTEN ()
      (WITHOUT-INTERRUPTS			;First try to pick up a pending RFC
	(DO ((PKT PENDING-RFC-PKTS (PKT-LINK PKT))
	     (PREV NIL PKT))
	    ((NULL PKT))
	  (COND ((STRING-EQUAL (CONTACT-NAME-FROM-RFC PKT) CONTACT-NAME)
		 (COND ((NULL PREV) (SETQ PENDING-RFC-PKTS (PKT-LINK PKT)))
		       (T (SETF (PKT-LINK PREV) (PKT-LINK PKT))))
		 (RFC-MEETS-LSN CONN PKT)
		 (RETURN-FROM LISTEN CONN))))
	(SETF (STATE CONN) 'LISTENING-STATE)	;No RFC, let listen pend
	(PUSH (CONS CONTACT-NAME CONN) PENDING-LISTENS))
      (COND (WAIT-FOR-RFC
	     (PROCESS-WAIT "Net Listen"
			   #'(LAMBDA (CONN) (NEQ (STATE CONN) 'LISTENING-STATE))
			   CONN)
	     (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
		 (FERROR 'SYS:BAD-CONNECTION-STATE-1
			 "Listening connection ~S entered bad state ~S"
			 CONN (STATE CONN)))))
      (RETURN CONN)))

;;; If you have done a LISTEN and the state has changed to RFC-RECEIVED, you
;;; call one of the following four functions.

;;; Send an OPN, and leave conn in OPEN-STATE.
;;; Note that when this returns the other end has not yet acknowledged
;;; the OPN, and the window size is still 0.  Transmitting the first packet
;;; will wait.
(DEFUN ACCEPT (CONN &AUX PKT)
  "Accept a request for a connection, received on connection-object CONN.
CONN should have been returned by a previous call to LISTEN.
Note that the connection is not completely established
until the other side replies to the packet we send."
    (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
        (FERROR 'SYS:BAD-CONNECTION-STATE-1
		"Attempt to accept ~S, which was in ~A, not RFC-RECEIVED-STATE"
		CONN (STATE CONN)))
    (SETQ PKT (READ-PKTS CONN))
    (COND (PKT					;In case the user has not read the RFC
	   (SETF (PKT-NUM-RECEIVED CONN) (PKT-NUM PKT))
	   (SETF (READ-PKTS CONN) (PKT-LINK PKT))
	   (OR (READ-PKTS CONN)
	       (SETF (READ-PKTS-LAST CONN) NIL))
	   (FREE-PKT PKT)))
    (SETQ PKT (ALLOCATE-PKT))
    (SETF (PKT-OPCODE PKT) OPN-OP)
    (SETF (PKT-NBYTES-on-write PKT) 4)
    (SETF (PKT-SECOND-DATA-WORD PKT) (LOCAL-WINDOW-SIZE CONN))
    (SETF (PKT-FIRST-DATA-WORD PKT) (PKT-NUM-READ CONN))
    (WITHOUT-INTERRUPTS
      (SETF (PKT-LINK PKT) NIL)
      (SETF (WINDOW-AVAILABLE CONN) 0)
      (SETF (TIME-LAST-RECEIVED CONN) (zl:TIME))
      (SETF (STATE CONN) 'OPEN-STATE))  ;Set this -before- telling other end it's open!
    (TRANSMIT-NORMAL-PKT CONN PKT T)
    (WITHOUT-INTERRUPTS
      ;; TRANSMIT-NORMAL-PKT fills in fields that must be filled before packet
      ;; can be put on transmit list
      (SETF (SEND-PKTS CONN) PKT)
      (SETF (SEND-PKTS-LAST CONN) PKT)
      (SETF (SEND-PKTS-LENGTH CONN) 1)
      (SETQ RETRANSMISSION-NEEDED T))
    T)

;;; Send a CLS and leave conn INACTIVE.
(DEFUN REJECT (CONN REASON)
  "Reject a request for a connection, received on connection-object CONN.
CONN should have been returned by a previous call to LISTEN.
REASON is a string to be sent to the requestor and returned from
his call to CONNECT."
    (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
        (FERROR 'SYS:BAD-CONNECTION-STATE-1
		"Attempt to reject ~S, which was in ~A, not RFC-RECEIVED-STATE"
		CONN (STATE CONN)))
    (CLOSE-CONN CONN REASON)
    T)

;; Send an ANS, and leave conn INACTIVE.
;; The caller passes in a PKT with data and NBYTES set up.
(DEFUN ANSWER (CONN PKT)
  "Reply to a simple transaction received on connection-object CONN.
PKT should be a packet with ANS as its opcode and the data and nbytes fields set up.
This is the proper way to answer when the requestor has used the function CHAOS:SIMPLE.
Note that there is no guarantee that the requestor will receive the answer;
he will just repeat the request if he does not.
See also CHAOS:ANSWER-STRING."
  (WHEN (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
    (SETF (PKT-OPCODE PKT) ANS-OP)
    (TRANSMIT-NORMAL-PKT CONN PKT))
  (RETURN-PKT PKT)
  (REMOVE-CONN CONN)
  T)

(DEFUN ANSWER-STRING (CONN STRING)
  "Reply to a simple transaction received on connection-object CONN.
STRING specifies the answer to send.
This is the proper way to answer when the requestor has used the function CHAOS:SIMPLE.
Note that there is no guarantee that the requestor will receive the answer;
he will just repeat the request if he does not.
See also CHAOS:ANSWER, a lower level way of answering."
  (LET ((PKT (GET-PKT)))
    (SETF (PKT-NBYTES-on-write PKT) (MIN (STRING-LENGTH STRING) MAX-DATA-BYTES-PER-PKT))
    (COPY-ARRAY-CONTENTS STRING (PKT-STRING PKT))
    (ANSWER CONN PKT)))

;;; Minimal-consing simple-transaction answerer.
;;; Returns T if succeeds, NIL if fails, although you probably don't care, since
;;; a value of T does not assure that the ANS really reached the requestor.
(DEFUN FAST-ANSWER-STRING (CONTACT-NAME STRING)
  "Reply to a simple transaction requested on CONTACT-NAME, with answer STRING.
This is like (ANSWER-STRING (LISTEN contact-name) string) but conses less."
  (PROG ((PREV NIL) RFC PKT PSTR)
    (WITHOUT-INTERRUPTS
      (SETQ RFC (DO PKT PENDING-RFC-PKTS (PKT-LINK PKT) (NULL PKT)
		    (AND (STRING-EQUAL (CONTACT-NAME-FROM-RFC PKT) CONTACT-NAME)
			 (RETURN PKT))
		    (SETQ PREV PKT)))
      (IF (NULL RFC) (RETURN NIL)
	  (IF (NULL PREV) (SETQ PENDING-RFC-PKTS (PKT-LINK RFC))
	      (SETF (PKT-LINK PREV) (PKT-LINK RFC)))))
    (setq pkt (net:allocate-packet))
    (SETF (PKT-NBYTES-on-write PKT) (MIN (STRING-LENGTH STRING) MAX-DATA-BYTES-PER-PKT))
    (SETQ PSTR	     ;Create indirect array to reference as a string
	  (MAKE-STRING MAX-DATA-BYTES-PER-PKT :FILL-POINTER 0
		       			      :DISPLACED-TO PKT
					      :DISPLACED-INDEX-OFFSET 16.))
    (COPY-ARRAY-CONTENTS STRING PSTR)
    ;(RETURN-ARRAY (PROG1 PSTR (SETQ PSTR NIL)))
    (SETF (PKT-SOURCE-ADDRESS PKT) MY-ADDRESS)
    (SETF (PKT-SOURCE-INDEX-NUM PKT) 0)
    (SETF (PKT-DEST-ADDRESS PKT) (PKT-SOURCE-ADDRESS RFC))
    (SETF (PKT-DEST-INDEX-NUM PKT) (PKT-SOURCE-INDEX-NUM RFC))
    (SETF (PKT-OPCODE PKT) ANS-OP)
    (SETF (PKT-NUM PKT) 0)
    (SETF (PKT-ACK-NUM PKT) 0)
    (TRANSMIT-INT-PKT PKT)
    (SETF (PKT-STATUS RFC) NIL)
    (FREE-PKT RFC)
    (RETURN T)))

(DEFUN FORWARD (CONN PKT HOST)
  "Forward a request for a connection to some other host and//or contact name.
CONN should be a connection object returned by LISTEN on which a
request has been received.  PKT should have opcode CHAOS:FWD-OP and its
data (and PKT-NBYTES) set to the new contact name to forward to.
HOST should specify the host to forward to."
  (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
      (FERROR 'SYS:BAD-CONNECTION-STATE-1
	      "Attempt to forward ~S, which was in ~A, not RFC-RECEIVED-STATE"
	      CONN (STATE CONN)))
  (SETF (PKT-OPCODE PKT) FWD-OP)
  (TRANSMIT-NORMAL-PKT CONN PKT 0 HOST)
  (RETURN-PKT PKT)
  (REMOVE-CONN CONN)
  T)

(DEFUN FORWARD-ALL (CONTACT-NAME HOST)
  "Tell all requests for chaosnet connections to CONTACT-NAME to try host HOST instead."
  (SETQ HOST (ADDRESS-PARSE HOST))
  (PUSH (LIST CONTACT-NAME
	      `(PROG (CONN)
		     (SETQ CONN (LISTEN ,CONTACT-NAME))
		     (FORWARD CONN (GET-NEXT-PKT CONN) ,HOST)))
	SERVER-ALIST)
  NIL)


;;;; Control operations used by both users and servers.

;;; If CONN has received a close, free it up.
;;; If CONN is inactive, do nothing.
;;; If CONN is open, send a CLS containing the reason, leaving CONN inactive.
(DEFUN CLOSE-CONN (CONN &OPTIONAL (REASON "") &AUX PKT)
  "Close a chaosnet connection, given connection-object CONN.
REASON is a string telling the other side why; but don't rely
on its being received."
    (CASE (STATE CONN)
      ((CLS-RECEIVED-STATE ANSWERED-STATE)
       (REMOVE-CONN CONN)
       NIL)
      (INACTIVE-STATE
       (SETQ CONN-LIST (DELQ CONN CONN-LIST))
       NIL)
      ((OPEN-STATE RFC-RECEIVED-STATE)
       (SETQ PKT (ALLOCATE-PKT))
       (SETF (PKT-OPCODE PKT) CLS-OP)
       (SET-PKT-STRING PKT REASON)
       (TRANSMIT-NORMAL-PKT CONN PKT)
       (FREE-PKT PKT)
       (REMOVE-CONN CONN)
       NIL)
      ((LOS-RECEIVED-STATE HOST-DOWN-STATE LISTENING-STATE RFC-SENT-STATE)
       (REMOVE-CONN CONN)
       NIL)
      (OTHERWISE
       (FERROR 'SYS:BAD-CONNECTION-STATE-1
	       "Attempt to close ~S, which was in ~S, not an acceptable state"
	       CONN (STATE CONN)))))

(DEFF CLOSE 'CLOSE-CONN)
(DEFF CHAOS-CLOSE 'CLOSE-CONN)
(MAKE-OBSOLETE CLOSE "use CHAOS:CLOSE-CONN")
(MAKE-OBSOLETE CHAOS-CLOSE "use CHAOS:CLOSE-CONN")

;;; Wait until either:
;;;  the state of CONN is not STATE  (return T), or
;;;  over TIMEOUT 60ths of a second happen (return NIL).
(DEFUN WAIT (CONN STATE TIMEOUT &OPTIONAL (WHOSTATE "Chaosnet Wait") &AUX START-TIME)
  "Wait for chaosnet connection CONN to be in a state other than STATE.
Alternatively, waiting ends after TIMEOUT time (measured in 60'ths).
Returns non-NIL iff the connection's state has changed.
WHOSTATE is a string to tell the user what you are waiting for."
   (SETQ START-TIME (zl:TIME))
   (DO () (NIL)
     (OR (EQ STATE (STATE CONN))
	 (RETURN T))
     (OR (< (TIME-DIFFERENCE (zl:TIME) START-TIME) TIMEOUT)
	 (RETURN NIL))
     (PROCESS-WAIT WHOSTATE
		   (FUNCTION (LAMBDA (CONN STATE START-TIME TIMEOUT)
				     (OR (NEQ (STATE CONN) STATE)
					 ( (TIME-DIFFERENCE (zl:TIME) START-TIME) TIMEOUT))))
		   CONN
		   STATE
		   START-TIME
		   TIMEOUT)))

;;; Send the specied format string, and eof and close
(DEFUN FORMAT-AND-EOF (CONN &REST FORMAT-ARGS)
  (CONDITION-CASE ()
      (PROGN
	(ACCEPT CONN)
	(WITH-OPEN-STREAM (STREAM (MAKE-STREAM CONN))
	  (APPLY #'FORMAT STREAM FORMAT-ARGS)))
    (SYS:REMOTE-NETWORK-ERROR NIL)))


;;;; Streams
;;; This is included in all chaosnet streams, input or output
(DEFFLAVOR BASIC-STREAM
	((CONNECTION NIL))
	()
  (:INCLUDED-FLAVORS SI:STREAM)
  (:INITABLE-INSTANCE-VARIABLES CONNECTION)
  (:GETTABLE-INSTANCE-VARIABLES CONNECTION))


;;; To find out what chaos host a stream is open to.
(DEFMETHOD (BASIC-STREAM :FOREIGN-HOST) ()
  (SI:GET-HOST-FROM-ADDRESS (FOREIGN-ADDRESS CONNECTION) :CHAOS))

(DEFMETHOD (BASIC-STREAM :CONTACT-NAME) () (CONTACT-NAME CONNECTION))

(DEFMETHOD (BASIC-STREAM :CLOSE) (&OPTIONAL ABORT-P)
  (WHEN CONNECTION				;Allowed to keep doing this
    (CLOSE-CONN CONNECTION (IF ABORT-P "Aborted" ""))
    (REMOVE-CONN (PROG1 CONNECTION (SETQ CONNECTION NIL)))))

(DEFMETHOD (BASIC-STREAM :ACCEPT) ()
  (ACCEPT CONNECTION))

(DEFMETHOD (BASIC-STREAM :REJECT) (&OPTIONAL REASON)
  (REJECT CONNECTION (OR REASON "")))

;;; These are new operations for the coming network system
(DEFMETHOD (BASIC-STREAM :ADD-AS-SERVER) (NAME &OPTIONAL (PROCESS CURRENT-PROCESS))
  (SEND TV:WHO-LINE-FILE-STATE-SHEET :ADD-SERVER CONNECTION NAME PROCESS))

(DEFMETHOD (BASIC-STREAM :DELETE-AS-SERVER) ()
  (SEND TV:WHO-LINE-FILE-STATE-SHEET :DELETE-SERVER CONNECTION))

(DEFMETHOD (BASIC-STREAM :NETWORK) () :CHAOS)

(DEFVAR *SECURITY-FUNCTION* NIL "If T, a predicate called with the chaos address")
(DEFUN SECURE-P-INTERNAL (CONNECTION)
  (IF *SECURITY-FUNCTION* (FUNCALL *SECURITY-FUNCTION* (FOREIGN-ADDRESS CONNECTION)) T))

(DEFMETHOD (BASIC-STREAM :SECURE-P) () (SECURE-P-INTERNAL CONNECTION))

;;; This is included in all chaosnet input streams, character and binary
(DEFFLAVOR INPUT-STREAM-MIXIN
	((INPUT-PACKET nil))
	()
  (:INCLUDED-FLAVORS SI:BASIC-BUFFERED-INPUT-STREAM))

(DEFMETHOD (INPUT-STREAM-MIXIN :DISCARD-INPUT-BUFFER) (IGNORE)
  (when input-packet
    (RETURN-PKT INPUT-PACKET)
    (setq input-packet nil)))

(defmethod (input-stream-mixin :before :close) (&rest ignore)
  (when input-packet
    (return-pkt input-packet)
    (setq input-packet nil)))

;;; This is included in all chaosnet output streams, character and binary
(DEFFLAVOR OUTPUT-STREAM-MIXIN
	(OUTPUT-PACKET)
	()
  (:INCLUDED-FLAVORS SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (OUTPUT-STREAM-MIXIN :DISCARD-OUTPUT-BUFFER) (IGNORE)
  (RETURN-PKT OUTPUT-PACKET)
  (SETQ OUTPUT-PACKET NIL))

;;; This is included in simple chaosnet input streams, but not file streams, where certain
;;; opcodes have special meaning.
(DEFFLAVOR BASIC-INPUT-STREAM
	((INPUT-PACKET NIL))
	(INPUT-STREAM-MIXIN BASIC-STREAM))

(DEFMETHOD (BASIC-INPUT-STREAM :GET-NEXT-INPUT-PKT) (NO-HANG-P &AUX OP)
  (COND ((AND INPUT-PACKET
	      (OR (= (SETQ OP (PKT-OPCODE INPUT-PACKET)) EOF-OP)
		  (= OP CLS-OP)))
	 NIL)
	((NULL (SETQ INPUT-PACKET (GET-NEXT-PKT CONNECTION NO-HANG-P "Chaosnet Input" T)))
	 NIL)
	((OR (= (SETQ OP (PKT-OPCODE INPUT-PACKET)) EOF-OP)
	     (= OP CLS-OP))
	 NIL)
	(( OP DAT-OP)
	 T)
	(T
	 (FERROR NIL "Unknown opcode ~O in packet ~S received from connection ~S"
		 OP INPUT-PACKET CONNECTION))))

(DEFMETHOD (BASIC-INPUT-STREAM :CLEAR-EOF) ()
  (COND ((AND INPUT-PACKET (= (PKT-OPCODE INPUT-PACKET) EOF-OP))
	 (RETURN-PKT INPUT-PACKET)
	 (SETQ INPUT-PACKET NIL))))

;;; This is included in simple chaosnet output streams, but not file streams, where a
;;; connection is maintained for longer.
(DEFFLAVOR BASIC-OUTPUT-STREAM
	()
	(OUTPUT-STREAM-MIXIN BASIC-STREAM)
  (:INCLUDED-FLAVORS SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (BASIC-OUTPUT-STREAM :EOF) ()
  (SEND SELF :FORCE-OUTPUT)
  (SEND-PKT CONNECTION (GET-PKT) EOF-OP)
  (FINISH-CONN CONNECTION))

(DEFMETHOD (BASIC-OUTPUT-STREAM :FINISH) ()
  (FINISH-CONN CONNECTION))

(DEFMETHOD (BASIC-OUTPUT-STREAM :BEFORE :CLOSE) (&OPTIONAL ABORT-P)
  (AND CONNECTION (NOT ABORT-P)
       (EQ (STATE CONNECTION) 'OPEN-STATE)
       (SEND SELF :EOF)))

(DEFFLAVOR CHARACTER-INPUT-STREAM-MIXIN
	(INPUT-PACKET)
	(INPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-INPUT-STREAM)
  ;; :GET-NEXT-INPUT-PKT returns T if INPUT-PACKET is a valid packet
  (:REQUIRED-METHODS :GET-NEXT-INPUT-PKT))

(DEFMETHOD (CHARACTER-INPUT-STREAM-MIXIN :ELEMENT-TYPE) () 'STRING-CHAR)

(DEFMETHOD (CHARACTER-INPUT-STREAM-MIXIN :NEXT-INPUT-BUFFER) (&OPTIONAL NO-HANG-P)
  (AND (SEND SELF :GET-NEXT-INPUT-PKT NO-HANG-P)
       (VALUES (PKT-STRING INPUT-PACKET)
	       0
	       (PKT-NBYTES INPUT-PACKET))))

(DEFFLAVOR BINARY-INPUT-STREAM-MIXIN
	(INPUT-PACKET)
	(INPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-INPUT-STREAM)
  (:REQUIRED-METHODS :GET-NEXT-INPUT-PKT))

(DEFMETHOD (BINARY-INPUT-STREAM-MIXIN :ELEMENT-TYPE) () '(UNSIGNED-BYTE 8))

(DEFMETHOD (BINARY-INPUT-STREAM-MIXIN :NEXT-INPUT-BUFFER) (&OPTIONAL NO-HANG-P)
  (AND (SEND SELF :GET-NEXT-INPUT-PKT NO-HANG-P)
       (LET ((ET (SEND-IF-HANDLES SELF :ELEMENT-TYPE)))
	 (COND ((AND (CONSP ET)
		     (MEMQ (CAR ET) '(UNSIGNED-BYTE SIGNED-BYTE))
		     (EQ 8 (CADR ET)))
		(VALUES (PKT-STRING INPUT-PACKET)
			0
			(PKT-NBYTES INPUT-PACKET)))
	       ('ELSE
		(VALUES INPUT-PACKET
			FIRST-DATA-WORD-IN-PKT
			(+ FIRST-DATA-WORD-IN-PKT (TRUNCATE (PKT-NBYTES INPUT-PACKET) 2))))))))

(DEFFLAVOR CHARACTER-OUTPUT-STREAM-MIXIN
	(OUTPUT-PACKET)
	(OUTPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (CHARACTER-OUTPUT-STREAM-MIXIN :ELEMENT-TYPE) () 'STRING-CHAR)

(DEFMETHOD (CHARACTER-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER) ()
  (SETQ OUTPUT-PACKET (GET-PKT))
  (VALUES (PKT-STRING OUTPUT-PACKET) 0 MAX-DATA-BYTES-PER-PKT))

(DEFMETHOD (CHARACTER-OUTPUT-STREAM-MIXIN :SEND-OUTPUT-BUFFER) SEND-CHARACTER-PKT)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (CHARACTER-OUTPUT-STREAM-MIXIN)
(DEFUN SEND-CHARACTER-PKT (IGNORE IGNORE LENGTH)
  (SETF (PKT-NBYTES-on-write OUTPUT-PACKET) LENGTH)
  (SEND-PKT CONNECTION OUTPUT-PACKET)
  (SETQ OUTPUT-PACKET NIL)))

(DEFFLAVOR BINARY-OUTPUT-STREAM-MIXIN
	(OUTPUT-PACKET)
	(OUTPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-OUTPUT-STREAM))

;due to unfortunate history, binary implies a default byte size of 16.
(DEFMETHOD (BINARY-OUTPUT-STREAM-MIXIN :ELEMENT-TYPE) () '(UNSIGNED-BYTE 16))

(DEFMETHOD (BINARY-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER) ()
  (SETQ OUTPUT-PACKET (GET-PKT))
  (LET ((ET (SEND-IF-HANDLES SELF :ELEMENT-TYPE)))
    (COND ((AND (CONSP ET)
		(MEMQ (CAR ET) '(UNSIGNED-BYTE SIGNED-BYTE))
		(EQ 8 (CADR ET)))
	   (VALUES (PKT-STRING OUTPUT-PACKET)
		   0
		   MAX-DATA-BYTES-PER-PKT))
	  ('ELSE
	   (VALUES OUTPUT-PACKET
		   FIRST-DATA-WORD-IN-PKT
		   (+ FIRST-DATA-WORD-IN-PKT (TRUNCATE MAX-DATA-BYTES-PER-PKT 2)))))))

(DEFMETHOD (BINARY-OUTPUT-STREAM-MIXIN :SEND-OUTPUT-BUFFER) (ARRAY END)
  (COND ((EQ ARRAY OUTPUT-PACKET)
	 (SEND-BINARY-PKT NIL NIL END))
	('ELSE
	 (SETF (PKT-NBYTES-ON-WRITE OUTPUT-PACKET) END)
	 (SEND-PKT CONNECTION OUTPUT-PACKET #o300)
	 (SETQ OUTPUT-PACKET NIL))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BINARY-OUTPUT-STREAM-MIXIN)
(DEFUN SEND-BINARY-PKT (IGNORE IGNORE LENGTH)
  (SETF (PKT-NBYTES-on-write OUTPUT-PACKET) (* (- LENGTH FIRST-DATA-WORD-IN-PKT) 2))
  (SEND-PKT CONNECTION OUTPUT-PACKET #o300)
  (SETQ OUTPUT-PACKET NIL)))


(DECLARE-FLAVOR-INSTANCE-VARIABLES (BINARY-OUTPUT-STREAM-MIXIN)
(DEFUN SEND-BINARY-PKT-8 (IGNORE IGNORE LENGTH)
  (SETF (PKT-NBYTES-ON-WRITE OUTPUT-PACKET) LENGTH)
  (SEND-PKT CONNECTION OUTPUT-PACKET #o300)
  (SETQ OUTPUT-PACKET NIL)))


(DECLARE-FLAVOR-INSTANCE-VARIABLES (BINARY-OUTPUT-STREAM-MIXIN)
(DEFUN SEND-BINARY-PKT-ANY (IGNORE ARRAY LENGTH)
  (COND ((EQ ARRAY CHAOS:OUTPUT-PACKET)
	 (CHAOS:SEND-BINARY-PKT NIL NIL LENGTH))
	('ELSE
	 (CHAOS:SEND-BINARY-PKT-8 NIL NIL LENGTH)))))




;;; Now the instantiatable flavors
(DEFFLAVOR INPUT-CHARACTER-STREAM
	()
	(CHARACTER-INPUT-STREAM-MIXIN BASIC-INPUT-STREAM SI:BUFFERED-INPUT-CHARACTER-STREAM))

(DEFFLAVOR OUTPUT-CHARACTER-STREAM
	()
	(CHARACTER-OUTPUT-STREAM-MIXIN BASIC-OUTPUT-STREAM
	 SI:BUFFERED-OUTPUT-CHARACTER-STREAM))

(DEFFLAVOR CHARACTER-STREAM
	()
	(CHARACTER-INPUT-STREAM-MIXIN CHARACTER-OUTPUT-STREAM-MIXIN
	 BASIC-INPUT-STREAM BASIC-OUTPUT-STREAM SI:BUFFERED-CHARACTER-STREAM))

;;; This is to make the EVAL server work
(DEFMETHOD (CHARACTER-STREAM :BEEP) (&OPTIONAL IGNORE)
  )

(COMPILE-FLAVOR-METHODS INPUT-CHARACTER-STREAM OUTPUT-CHARACTER-STREAM CHARACTER-STREAM )

(DEFFLAVOR INPUT-BINARY-STREAM
	()
	(BINARY-INPUT-STREAM-MIXIN BASIC-INPUT-STREAM
	 SI:BUFFERED-INPUT-STREAM))

(DEFFLAVOR OUTPUT-BINARY-STREAM
	()
	(BINARY-OUTPUT-STREAM-MIXIN BASIC-OUTPUT-STREAM
	 SI:BUFFERED-OUTPUT-STREAM))

(DEFFLAVOR BINARY-STREAM
	()
	(BINARY-INPUT-STREAM-MIXIN BINARY-OUTPUT-STREAM-MIXIN
	 BASIC-INPUT-STREAM BASIC-OUTPUT-STREAM SI:BUFFERED-STREAM))

(COMPILE-FLAVOR-METHODS INPUT-BINARY-STREAM OUTPUT-BINARY-STREAM BINARY-STREAM)

(DEFFLAVOR ASCII-TRANSLATING-INPUT-CHARACTER-STREAM
	()
	(SI:ASCII-TRANSLATING-INPUT-STREAM-MIXIN
	 CHARACTER-INPUT-STREAM-MIXIN BASIC-INPUT-STREAM
	 SI:BUFFERED-TYI-INPUT-STREAM))

(DEFFLAVOR ASCII-TRANSLATING-OUTPUT-CHARACTER-STREAM
	()
	(SI:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN
	 CHARACTER-OUTPUT-STREAM-MIXIN BASIC-OUTPUT-STREAM
	 SI:BUFFERED-TYO-OUTPUT-STREAM))

(DEFFLAVOR ASCII-TRANSLATING-CHARACTER-STREAM
	()
	(SI:ASCII-TRANSLATING-INPUT-STREAM-MIXIN SI:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN
	 CHARACTER-INPUT-STREAM-MIXIN CHARACTER-OUTPUT-STREAM-MIXIN
	 BASIC-INPUT-STREAM BASIC-OUTPUT-STREAM SI:BUFFERED-TYI-TYO-STREAM))

(COMPILE-FLAVOR-METHODS ASCII-TRANSLATING-INPUT-CHARACTER-STREAM
			ASCII-TRANSLATING-OUTPUT-CHARACTER-STREAM
			ASCII-TRANSLATING-CHARACTER-STREAM)

(DEFUN OPEN-STREAM (HOST CONTACT-NAME &KEY &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE)
						     (TIMEOUT (* 10. 60.))
						     (DIRECTION :BIDIRECTIONAL)
						     (ERROR T)
						     (CHARACTERS T)
						     (ASCII-TRANSLATION NIL)
				      &AUX CONN)
  "Open a chaosnet connection and return a stream that does i//o to it.
HOST is the host to connect to; CONTACT-NAME is the contact name at that host.
The keyword arguments are:
:WINDOW-SIZE - number of packets to allow in transit to this host over the connection.
:TIMEOUT - how long to wait before assuming the host is down.
:ASCII-TRANSLATION - if non-NIL, assume the data on the connection is in ASCII
 and translate to and from the Lisp machine character set as appropriate.
:DIRECTION, :CHARACTERS, :ERROR - as in OPEN.  :DIRECTION defaults to :BIDIRECTIONAL."
  (CONDITION-CASE-IF (NOT ERROR) (ERROR-OBJECT)
        (SETQ CONN (IF HOST
		       (CONNECT HOST CONTACT-NAME WINDOW-SIZE TIMEOUT)
		       (LISTEN CONTACT-NAME WINDOW-SIZE)))
    (SYS:REMOTE-NETWORK-ERROR ERROR-OBJECT)
    (:NO-ERROR 
      (MAKE-STREAM CONN :DIRECTION DIRECTION
		   	:CHARACTERS CHARACTERS
			:ASCII-TRANSLATION ASCII-TRANSLATION))))

(DEFUN MAKE-STREAM (CONNECTION &KEY &OPTIONAL (DIRECTION :BIDIRECTIONAL)
					      (CHARACTERS T)
					      (ASCII-TRANSLATION NIL))
  "Return a stream that does I//O to an already established chaos connection.
:ASCII-TRANSLATION - if non-NIL, assume the data on the connection is in ASCII
 and translate to and from the Lisp machine character set as appropriate.
:DIRECTION, :CHARACTERS - as in OPEN.  :DIRECTION defaults to :BIDIRECTIONAL."
  (MAKE-INSTANCE (CASE DIRECTION
		   (:INPUT
		    (COND (ASCII-TRANSLATION 'ASCII-TRANSLATING-INPUT-CHARACTER-STREAM)
			  (CHARACTERS 'INPUT-CHARACTER-STREAM)
			  (T 'INPUT-BINARY-STREAM)))
		   (:OUTPUT
		    (COND (ASCII-TRANSLATION 'ASCII-TRANSLATING-OUTPUT-CHARACTER-STREAM)
			  (CHARACTERS 'OUTPUT-CHARACTER-STREAM)
			  (T 'OUTPUT-BINARY-STREAM)))
		   (:BIDIRECTIONAL
		    (COND (ASCII-TRANSLATION 'ASCII-TRANSLATING-CHARACTER-STREAM)
			  (CHARACTERS 'CHARACTER-STREAM)
			  (T 'BINARY-STREAM))))
		 :CONNECTION CONNECTION))

(DEFF STREAM 'MAKE-STREAM)
(MAKE-OBSOLETE STREAM "use MAKE-STREAM")

;;;; Useful information gatherers

;;; HOST-DATA: returns information about a specified host.  Currently,
;;; returns name of machine as primary value and host number as second value
(DEFUN HOST-DATA (&OPTIONAL (HOST MY-ADDRESS) &AUX HOST-ADDRESS HOST-NAME TEM)
  "Return the long name and chaos address of a host."
  (DECLARE (RETURN-LIST HOST-NAME HOST-ADDRESS))
  (OR (SETQ HOST-ADDRESS (ADDRESS-PARSE HOST))
      (FERROR NIL "~S is an illegal host specification" HOST))
  (IF (AND (SETQ HOST-NAME (SI:GET-HOST-FROM-ADDRESS HOST-ADDRESS :CHAOS))
	   (SETQ HOST-NAME (SEND HOST-NAME :NAME)))
      (AND (SETQ TEM (ASSOC-EQUALP HOST-NAME SI:MACHINE-LOCATION-ALIST))
	   (SETQ HOST-NAME (SECOND TEM)))
    (IF (SETQ TEM (GET-HOST-STATUS-PACKET HOST-ADDRESS))
	(LET ((STRING (PKT-STRING TEM)))
	  (SETQ HOST-NAME (SUBSTRING STRING 0
				     (MIN (PKT-NBYTES TEM) 32.
					  (OR (STRING-SEARCH-CHAR 0 STRING) 32.)))))
      (SETQ HOST-NAME "Unknown")))
  (VALUES HOST-NAME HOST-ADDRESS))

;;; If given a number, this always returns something that ADDRESS-PARSE would make into that
;;; number.
(DEFUN HOST-SHORT-NAME (HOST &AUX HOST1)
  "Return a brief name for the specified host."
  (COND ((NOT (NUMBERP HOST))
	 (SEND (SI:PARSE-HOST HOST) :SHORT-NAME))
	((SETQ HOST1 (SI:GET-HOST-FROM-ADDRESS HOST :CHAOS))
	 (SEND HOST1 :SHORT-NAME))
	(T (FORMAT NIL "~O" HOST))))

;(FSET 'HOST-SYSTEM-TYPE 'SI:HOST-SYSTEM-TYPE)

(DEFUN GET-HOST-STATUS-PACKET (HOST &AUX CONNECTION PKT ADR)
  "Returns a STATUS packet from the specified host or NIL if couldn't get the packet"
  (ASSURE-ENABLED)
  (SETQ ADR (OR (ADDRESS-PARSE HOST)
		(FERROR NIL "Not a known Chaos address: ~S" HOST)))
  (SETQ CONNECTION (OPEN-CONNECTION ADR "STATUS" 1))
  (DO () ((NULL CONNECTION))
      (PROCESS-SLEEP 10.)			;Take a few chaos net interrupts
      (CASE (STATE CONNECTION)
	(RFC-SENT-STATE
	  (COND (( (TIME-DIFFERENCE (zl:TIME) (TIME-LAST-RECEIVED CONNECTION))
		    300.)		;5-second timeout
		 (REMOVE-CONN CONNECTION)
		 (RETURN NIL))))
	(ANSWERED-STATE				;This is what we want
	  (SETQ PKT (GET-NEXT-PKT CONNECTION))
	  (CLOSE-CONN CONNECTION)
	  (RETURN PKT))
	(CLS-RECEIVED-STATE (CLOSE-CONN CONNECTION) (RETURN NIL))
	(OPEN-STATE
	  (CLOSE-CONN CONNECTION "I expected an ANS, not an OPN.")
	  (RETURN NIL))
	(LOS-RECEIVED-STATE
	  (CLOSE-CONN CONNECTION)
	  (RETURN NIL))
	(OTHERWISE
	  (CLOSE-CONN CONNECTION)
	  (RETURN NIL)))))

(DEFUN ON-CHAOSNET-P (HOST)
  "Return T if HOST has a chaosnet address."
  (SEND (SI:PARSE-HOST HOST) :NETWORK-TYPEP :CHAOS))

(DEFINE-SITE-VARIABLE USUAL-LM-NAME-PREFIX :USUAL-LM-NAME-PREFIX)

(DEFUN GET-SHORT-LM-NAME (LM &AUX (PL (STRING-LENGTH USUAL-LM-NAME-PREFIX)))
  (IF USUAL-LM-NAME-PREFIX
      (DO ((L (SEND LM :HOST-NAMES) (CDR L)))
	  ((NULL L) (SEND LM :SHORT-NAME))
	(AND (STRING-EQUAL USUAL-LM-NAME-PREFIX (CAR L) :END1 PL :END2 PL)
	     (RETURN (CAR L))))
    (SEND LM :SHORT-NAME)))


;;; This isn't DEFINE-SITE-HOST-LIST because this file is loaded too early,
;;; as is the SITE file itself.
(DEFINE-SITE-VARIABLE TIME-SERVER-HOSTS :CHAOS-TIME-SERVER-HOSTS)

(SETQ TIME:*NETWORK-TIME-FUNCTION* 'HOST-TIME)

;;; Returns universal time from host over the net, as a 32-bit number
;;; or if it can't get the time, returns a string which is the reason why not.
;;; This applies each host for the time at a rate of one per second.
;;; As soon as one of them replies, it returns the time that host gave.
;;; 2nd value is host from which time was gotten.
(DEFUN HOST-TIME (&OPTIONAL (HOSTS TIME-SERVER-HOSTS) &AUX CONNECTIONS LAST-HOST)
  (ASSURE-ENABLED)
  (AND (NLISTP HOSTS)
       (NOT (NULL HOSTS))
       (SETQ HOSTS (LIST HOSTS)))
  (SETQ LAST-HOST (CAR (LAST HOSTS)))
  (UNWIND-PROTECT
    (LOOP NAMED HOST-TIME
	  FOR HOST IN HOSTS
	  AS ADDRESS = (ADDRESS-PARSE HOST)
	  WHEN (AND ADDRESS ( ADDRESS MY-ADDRESS))
	    DO (PUSH (OPEN-CONNECTION (ADDRESS-PARSE HOST) "TIME" 5) CONNECTIONS)
	       (COND ((PROCESS-WAIT-WITH-TIMEOUT "Ask the Time"
			(IF (EQ HOST LAST-HOST) 300. 60.)
			#'(LAMBDA (CONNECTIONS)
			    (LOOP FOR CONNECTION IN CONNECTIONS
				  WHEN (EQ (STATE CONNECTION) 'ANSWERED-STATE)
				  RETURN T))
			CONNECTIONS)
		      (LOOP WITH PKT
			    FOR CONNECTION IN CONNECTIONS
			    WHEN (EQ (STATE CONNECTION) 'ANSWERED-STATE)
			    DO (RETURN-FROM HOST-TIME
				 (VALUES
				   (PROG2 (SETQ PKT (GET-NEXT-PKT CONNECTION))
					  (DECODE-CANONICAL-TIME-PACKET PKT)
					  (RETURN-PKT PKT))
				   (SI:GET-HOST-FROM-ADDRESS
				     (FOREIGN-ADDRESS CONNECTION) :CHAOS))))))
	  ELSE UNLESS ADDRESS DO
	  (FORMAT *ERROR-OUTPUT* "~&Invalid host given to HOST-TIME by ~S" HOST)
	  FINALLY (RETURN "No hosts responded."))
    (MAPC 'CLOSE-CONN CONNECTIONS)))


;; Copied from LAD: RELEASE-3.NETWORK.CHAOS; CHUSE.LISP#28 on 2-Oct-86 17:22:45
(network:define-network-function (network:get-host-time :chaos) (host)
  (multiple-value-bind (time ahost)
      (host-time (list host))
    (if ahost time)))
  

(DEFUN CHAOS-UNKNOWN-HOST-FUNCTION (NAME)
  (DOLIST (HOST (SI:GET-SITE-OPTION :CHAOS-HOST-TABLE-SERVER-HOSTS))
    (AND (SI:PARSE-HOST HOST T ())		; prevent infinite recursion
	 (WITH-OPEN-STREAM (STREAM (OPEN-STREAM HOST "HOSTAB" :ERROR NIL))
	   (SETQ NAME (STRING NAME))
	   (UNLESS (ERRORP STREAM)
	     (SEND STREAM :LINE-OUT NAME)
	     (SEND STREAM :FORCE-OUTPUT)
	     (DO ((LIST NIL) (RESULT) (DONE)
		  (LINE) (EOF)
		  (LEN) (SP) (PROP))
		 (DONE RESULT)
	       (MULTIPLE-VALUE (LINE EOF) (SEND STREAM :LINE-IN))
	       (cond (EOF
		      (SETQ RESULT (WHEN LIST
				     (PUTPROP LIST (STABLE-SORT (GET LIST :HOST-NAMES)
								#'(LAMBDA (X Y)
								    (< (STRING-LENGTH X)
								       (STRING-LENGTH Y))))
					      :HOST-NAMES)
				     (APPLY #'SI:DEFINE-HOST LIST))
			    DONE T))
		     (t
		      (SETQ LEN (STRING-LENGTH LINE)
			    SP (STRING-SEARCH-CHAR #\SP LINE 0 LEN))
		      (SETQ PROP (INTERN (SUBSTRING LINE 0 SP) ""))
		      (INCF SP)
		      (CASE PROP
			(:ERROR (SETQ DONE T))
			(:NAME
			 (LET ((NAME (SUBSTRING LINE SP LEN)))
			   (OR LIST (SETQ LIST (NCONS NAME)))
			   (PUSH NAME (GET LIST :HOST-NAMES))))
			((:SYSTEM-TYPE :MACHINE-TYPE)
			 (PUTPROP LIST (INTERN (SUBSTRING LINE SP LEN) "") PROP))
			(OTHERWISE
			 (LET ((FUNCTION (GET PROP 'NET:ADDRESS-PARSER)))
			   (OR FUNCTION (SETQ FUNCTION (GET :CHAOS 'NET:ADDRESS-PARSER)))
			   (PUSH (FUNCALL FUNCTION PROP LINE SP LEN)
				 (GET LIST PROP))))))))
	     (RETURN T))))))

(SETQ SI:UNKNOWN-HOST-FUNCTION 'CHAOS-UNKNOWN-HOST-FUNCTION)

(DEFUN NEW-HOST-VALIDATION-FUNCTION (HOST SYSTEM-TYPE ADDRESS)
  (COND ((NOT (STRINGP HOST))
	 (AND ADDRESS
	      (NOT (MEMQ ADDRESS (SEND HOST :CHAOS-ADDRESSES)))
	      (FERROR NIL "~O is not a valid chaosnet address for ~A" ADDRESS HOST))
	 HOST)
	(T
	 (LET ((STATUS-PKT (GET-HOST-STATUS-PACKET ADDRESS)))
	   (OR STATUS-PKT (FERROR NIL "Cannot connect to ~A at ~O" HOST ADDRESS))
	   (LET ((STRING (PKT-STRING STATUS-PKT)))
	     (OR (FQUERY NIL "Host is ~A, ok? "
			 (SUBSTRING STRING 0 (MIN (STRING-LENGTH STRING) 32.
						  (OR (STRING-SEARCH-SET '(#o200 0) STRING)
						      32.))))
		 (FERROR NIL "Incorrect host specified"))))
	 (SI:DEFINE-HOST HOST :HOST-NAMES `(,HOST)
			      :SYSTEM-TYPE SYSTEM-TYPE
			      :CHAOS `(,ADDRESS))
	 (SETQ HOST (SI:PARSE-HOST HOST))
	 (AND (EQ CHAOS:MY-ADDRESS ADDRESS) (SETQ SI:LOCAL-HOST HOST))
	 HOST)))

(setf (get 'si:new-host-validation-function :chaos) 'chaos:new-host-validation-function)