;;; -*- Mode:Common-Lisp; Package:IP; Base:10; Fonts:(COURIER TR12I TR12BI TR12 MEDFNTB); Patch-file:T -*-

;1 FIle name: TCP-STREAM.LISP*
;1 Lets the TCP-STREAM medium know about the UNIX stream type*
;1 Started 3-7-1989 by Eric Karlson, UC-Berkeley under Robert Wilensky*
;1 Phone: (415) 642-9076, E-mail Address: karlson@ucbarpa.berkeley.edu*

;1--------------------------------------------*
;1 Define the flavors for the new UNIX streams*
;1--------------------------------------------*

(defflavor 4Unix-Translating-Input-Stream-Mixin*
 ((last-char-cr-p nil))			   ;1 Tells if last character of last buffer was a CR.*
 (basic-input-stream)
 (:included-flavors character-input-stream-mixin)
 (:documentation
"3Translates Characters that are sent over a UNIX connection where UNIX uses lone LineFeeds
instead of Carriage Return/LineFeed pairs for newlines. Also translates CR|LF pairs and lone
CRs into NewLines.*"))

(defmethod 4(unix-translating-input-stream-mixin :around :next-input-buffer*) (cont mt args ignore)
"2Translates characters in the buffer from UNIX to TI.*"
  (declare (function (:METHOD unix-translating-input-stream-mixin :around :next-input-buffer) (T T LIST T)
		     (or NULL ARRAY) FIXNUM FIXNUM)
	   (values BUFFER START END))
  (multiple-value-bind (buffer start end) (around-method-continue cont mt args)
    (declare (type (or NULL ARRAY) buffer)
	     (FIXNUM start end))
    (when buffer
      (do ((i start (1+ i))
	   (j start (1+ j))
	   (old-last-char-cr-p (prog1 last-char-cr-p
				      (setf last-char-cr-p nil)))
	   look)
	  ((eql i end)
	   (setf end j))
	(declare (FIXNUM i j)
		 (SYMBOL old-last-char-cr-p)
		 (type (or NULL FIXNUM) look))
	;1 Translate the character.*
	(setf (aref buffer j)
	      (case (aref buffer i)
		(8 (char-code #\Backspace))
		(9 (char-code #\Tab))
		(10 (if (and (eql i start) old-last-char-cr-p)
			(decf j))
		    (char-code #\Newline))
		(12 (char-code #\Page))
		(13 (if (and (not (eql (setf look (1+ i)) end))
			     (eql (aref buffer look) 10))
			(setf i look)
			(setf last-char-cr-p (eql look end)))
		    (char-code #\Newline))
		(127 (char-code #\Rubout))
		(Otherwise (aref buffer i))))))
    (values buffer start end))) 

(defflavor 4Unix-Translating-Output-Stream-Mixin*
 ((translate T))			   ;1 Tells whether to translate the output or not.*
 (basic-output-stream)
 (:included-flavors basic-stream si:basic-buffered-output-stream)
 (:documentation
"3Defines a stream that will translate TI Characters into their equivilant UNIX characters.
In addition, the translation can be suspended by sending a :SUSPEND-OUTPUT-TRANSLATION
message to the stream and resumed with a :RESUME-OUTPUT-TRANSLATION. These methods
are there so that literal text can be sent along with normal text.*"))

(defmethod 4(unix-translating-output-stream-mixin :new-output-buffer*) ()
"2Allocates a new output buffer for the stream.*"
  (declare (function (:METHOD unix-translating-output-stream-mixin :new-output-buffer) () ARRAY FIXNUM FIXNUM)
	   (values BUFFER START-INDEX END-INDEX))
  (let ((buffer (allocate-resource 'TCP-STREAM-ASCII-BUFFER)))
    (declare (ARRAY buffer))
    (values buffer 0 (array-dimension buffer 0))))

(defmethod 4(unix-translating-output-stream-mixin :suspend-output-translation*) ()
"2Flushes out the current contents of the buffer and then turns off the translation flag.*"
  (declare (function (:METHOD unix-translating-output-stream-mixin :suspend-output-translation) () NULL)
	   (values NIL))
  (send self :force-output)
  (setq translate nil))

(defmethod 4(unix-translating-output-stream-mixin :resume-output-translation*) ()
"2Flushes out the current contents of the buffer and then turns on the translation flag.*"
  (declare (function (:METHOD unix-translating-output-stream-mixin :resume-output-translation) () SYMBOL)
	   (values T))
  (send self :force-output)
  (setq translate T))

(defmethod 4(unix-translating-output-stream-mixin :send-output-buffer*) (buffer character-index &aux segment)
"2Transmit the output buffer, translating if it is called for.*"
  (declare (function (:METHOD unix-translating-output-stream-mixin :send-output-buffer) (ARRAY FIXNUM &aux T)
		     T))
  ;1 Find segment to receive translated data*
  (when (and (setf segment (send connection :send-q-end))
	     (or (= (segment-index segment) (segment-size segment)) (tcp-header-push-p segment)))
    (send self :flush-buffer))
  (when (not (setf segment (send connection :send-q-end)))
    (setf segment (allocate-resource 'tcp-segment (send connection :maximum-send-size))
	  (tcp-header-ack-p segment) T)
    (without-interrupts
      (if (send connection :send-q-end)
	  (setf (segment-link (send connection :send-q-end)) segment)
	  (setf (send connection :send-q) segment))
      (setf (send connection :send-q-end) segment)))

  ;1 Translate entire buffer if needed.*
  (do ((i 0 (1+ i))
       (j (segment-index segment) (1+ j)))
      (nil)
    (declare (FIXNUM i j))
    (when (or (= i character-index) (= j (segment-size segment)))
      ;1 Complete current segment*
      (setf (segment-index segment) j)
      (cond ((or send-urgent-mode-p
		 (and urgent-output-index (< i urgent-output-index)))
	     (setf (tcp-header-urgent-p segment) T
		   (tcp-header-urgent-pointer segment) (- j (* 4. (tcp-header-data-offset segment)))))
	    ( urgent-output-index
	     (setf (tcp-header-urgent-p segment) T
		   (tcp-header-urgent-pointer segment) (- (- j (* 4 (tcp-header-data-offset segment)))
							  (- i urgent-output-index))
		   urgent-output-index nil)))

      ;1 Finished?*
      (when (= i character-index)
	(return))

      ;1 Allocate new segment*
      (setf segment (allocate-resource 'TCP-SEGMENT (send connection :maximum-send-size))
	    (tcp-header-ack-p segment) T)
      (without-interrupts
	(if (send connection :send-q-end)
	    (setf (segment-link (send connection :send-q-end)) segment)
	    (setf (send connection :send-q) segment))
	(setf (send connection :send-q-end) segment))
      (setf j (segment-index segment)))

    ;1 Translate one character.*
    ;1 Notice that NewLines are changed inot lone LineFeeds.*
    (if translate
	(case (aref buffer i)
	  (#.(char-code #\Backspace) (setf (aref segment j) 8))
	  (#.(char-code #\Tab) (setf (aref segment j) 9))
	  (#.(char-code #\Linefeed) (setf (aref segment j) 10))
	  (#.(char-code #\Page) (setf (aref segment j) 12))
	  (#.(char-code #\Newline) (setf (aref segment j) 10))
	  (#.(char-code #\Rubout) (setf (aref segment j) 127))
	  (otherwise (setf (aref segment j) (aref buffer i))))
	(setf (aref segment j) (aref buffer i))))

  ;1 Now transmit the buffer.*
  (when (buffer-push-p buffer)
    (setf (tcp-header-push-p (send connection :send-q-end)) t))
  (deallocate-resource 'TCP-STREAM-ASCII-BUFFER buffer)
  (send connection :external-drive-connection))

(defmethod 4(unix-translating-output-stream-mixin :force-output*) ()
"2Force the current output buffer out to the foreign host.*"
  (declare (function (:METHOD unix-translating-output-stream-mixin :force-output) () T))
  (when (null si::stream-output-buffer)
    (send self :setup-new-output-buffer))
  (setf (buffer-push-p si::stream-output-buffer) t)
  (send self :send-current-output-buffer))

(defmethod 4(unix-translating-output-stream-mixin :discard-output-buffer*) (buffer)
"2Deallocate the output buffer.*"
  (declare (function (:METHOD unix-translating-output-stream-mixin :new-output-buffer) () SYMBOL)
	   (values T))
  (deallocate-resource 'TCP-STREAM-ASCII-BUFFER buffer))

;1--------------------*
;1 Instantiable flavors*
;1--------------------*

(defflavor 4Unix-Translating-Input-Character-Stream*
 ()
 (unix-translating-input-stream-mixin
  basic-input-stream
  si:buffered-input-character-stream))

(defflavor 4Unix-Translating-Output-Character-Stream*
 ()
 (unix-translating-output-stream-mixin
  basic-output-stream
  si:buffered-output-character-stream))

(defflavor 4Unix-Translating-Character-Stream*
 ()
 (unix-translating-input-stream-mixin
  unix-translating-output-stream-mixin
  basic-input-stream
  basic-output-stream
  si:buffered-character-stream))

(compile-flavor-methods unix-translating-input-character-stream
			unix-translating-output-character-stream
			unix-translating-character-stream)

;1--------------------------------------*
;1 Redefine the OPEN-STREAM function*
;1--------------------------------------*

(DEFUN 4open-stream* (host &key &optional (local-port 0) (remote-port 0) (direction :bidirectional)
		    (characters t) (wait-for-establishment t) (timeout 10)
		    (timeout-after-open (WHEN timeout 300)) (error t)
		    (input-buffer-size *default-tcp-stream-input-buffer-size*) (number-of-input-buffers 2)
		    &aux (host-name "3Unknown*") connection mode destination-address stream normal-exit
		    default-timeout-handler timeout-occurred-p)
"2Establish a TCP connection and return a stream object for accessing that connection.
HOST The host to connect to.  May be a name, IP address, or host object.  If nil, the open is passive (listen).
:LOCAL-PORT (Optional) The local TCP port.  If 0 (default), a non-well known port will be generated and used.
:REMOTE-PORT (Optional) The remote TCP port on the specified host.  May be 0 (default) for passive opens.
:DIRECTION (Optional) :Input, :output, or :bidirectional (default).
:CHARACTERS (Optional) Either t (characters, the default), nil (binary), :ascii (ascii characters) or :unix (unix remote stream)
:WAIT-FOR-ESTABLISHMENT (Optional) If nil, don't wait for connection establishment (default t).
:TIMEOUT  (Optional) The timeout (in seconds) used in open-stream when waiting for establishment.  
  Nil indicates no timeout.  Default is 10 seconds.
:TIMEOUT-AFTER-OPEN (Optional) The timeout used after the connection has been established.  Nil indicates no timeout.  
  The default for user-timeout is 300 seconds when :TIMEOUT is non-nil, and nil when :TIMEOUT is nil.  
  This timeout is used for the TCP 'user timeout' (the timeout on acknowledgement of data sent), and also used as 
  the timeout on :next-input-buffer.  This timeout can be changed after open-stream by sending the stream a :set-timeout message.
:ERROR (Optional) If t (default), error conditions will be signaled in open-stream.  Otherwise, the error condition will be returned.
:INPUT-BUFFER-SIZE (Optional) The size of the receive window in characters (default 2048).  For binary streams
  each character occupies two octets.
:NUMBER-OF-INPUT-BUFFERS (Optional) The number of input buffers supplied to TCP (default 2).*"
  (flet
    ;1 Internal function*
    ((make-stream (connection direction characters timeout input-buffer-size number-of-input-buffers
			      &aux stream)
		  ;1 ftp provides its own stream instantiator*
		  (let ((*TCP-STREAM-INSTANTIATOR*
			  (OR *TCP-STREAM-INSTANTIATOR*
			      #'(lambda (connection timeout input-buffer-size number-of-input-buffers)
				  (case direction
				    (:INPUT
				     (make-instance
				       (cond
					 ((eq characters :ASCII) 'Ascii-Translating-Input-Character-Stream)
					 ((eq characters :UNIX) 'Unix-Translating-Input-Character-Stream)
					 ( characters 'Input-Character-Stream)
					 ( T 'Input-Binary-Stream))
				       :connection connection
				       :timeout timeout
				       :input-buffer-size input-buffer-size
				       :number-of-input-buffers number-of-input-buffers))
				    (:OUTPUT
				     (make-instance
				       (cond
					 ((eq characters :ASCII) 'Ascii-Translating-Output-Character-Stream)
					 ((eq characters :UNIX) 'Unix-Translating-Output-Character-Stream)
					 ( characters 'Output-Character-Stream)
					 ( T 'Output-Binary-Stream))
				       :connection connection
				       :timeout timeout))
				    (:BIDIRECTIONAL
				     (make-instance
				       (cond
					 ((eq characters :ASCII) 'Ascii-Translating-Character-Stream)
					 ((eq characters :UNIX) 'Unix-Translating-Character-Stream)
					 ( characters 'Character-Stream)
					 ( T 'Binary-Stream))
				       :connection connection
				       :timeout timeout
				       :input-buffer-size input-buffer-size
				       :number-of-input-buffers number-of-input-buffers)))))))
		    (setf stream
			  (funcall *TCP-STREAM-INSTANTIATOR* connection timeout input-buffer-size number-of-input-buffers)))
		  ;1 Insert actual handlers now that stream is known*
		  (setf (send connection :buffer-handler)
			#'(lambda (length push-p urgent-p)
			    (send stream :buffer-handler length push-p urgent-p)))
		  (setf (send connection :urgent-handler)
			#'(lambda ()
			    (send stream :urgent-handler)))
		  (setf (send connection :process-fin-handler)
			#'(lambda ()
			    (send stream :process-fin-handler)))
		  (setf (send connection :receive-fin-handler)
			#'(lambda ()
			    (send stream :receive-fin-handler)))
		  (setf (send connection :close-complete-handler)
			#'(lambda ()
			    (send stream :close-complete-handler)))
		  (setf (send connection :user-timeout-handler)
			#'(lambda ()
			    (send stream :timeout-handler :user-timeout)))
		  (setf (send connection :condition-handler)
			#'(lambda (condition-object)
			    (send stream :condition-handler condition-object)))
		  stream))
    ;1 Body of open-stream*
    (condition-case-if (not error) (error-object)
	(progn
	 (cond (host
		(setf mode :active)
		(setf host (parse-ip-host-spec host))
		(setf host-name (send host :short-name))	      
		(setf destination-address (first (closest-addresses-to-network (get-ip-addresses host)))))
	       (t (setf mode :passive)
		  (setf destination-address 0)))
	 (setf connection (send *TCP-HANDLER* :make-connection nil nil nil nil nil nil nil))
	 (setf stream (make-stream connection direction characters timeout input-buffer-size number-of-input-buffers))
	 ;1 Use special handler until connection is established*
	 (setf default-timeout-handler (send connection :user-timeout-handler))
	 (setf (send connection :user-timeout-handler) #'(lambda ()
							   (setf timeout-occurred-p t)))
	 (unwind-protect
	     (progn
	       (send connection :open local-port remote-port destination-address mode timeout)
	       (send stream :load-receives)
	       (if (not wait-for-establishment)
		   (setf normal-exit t)
		   (do ()
		       ((catch-error-restart-explicit-if error
							 (host-not-responding-during-connection
							   :retry-connection
							   "3Try the connection again.*")
			  (setf timeout-occurred-p nil)
			  (when (not (process-wait-with-timeout
				       (cond
					 (*TCP-STREAM-WHOSTATE*)
					 ((null host) "3TCP Listen*")
					 (t
					  (format () "3TCP Connect: ~A*" host-name)))
				       ;1 When waiting for active establishment we depend on the tcp user timeout*
				       (if (or (eq mode :active) (null timeout))
					   ()
					   (* timeout 60))
				       #'(lambda (connection)
					   (case (send connection :state)
					     ((:listen :syn-sent :syn-received) timeout-occurred-p)
					     (otherwise t)))
				       connection))
			    ;1 When timing out passive establishment we must explicitly call the user-timeout-handler*
			    (funcall (send connection :user-timeout-handler)))
			  (if timeout-occurred-p
			      (ferror 'host-not-responding-during-connection "3Host ~*~A not responding.*"
				      connection host-name)
			      t))
			(setf normal-exit t))
		     (when (and timeout (<= timeout 60))
		       (setf timeout 60)
		       (setf (send connection :user-timeout) timeout)))))
	   (when (not (or normal-exit (eq (send connection :status) :closed)))
	     (send connection :abort)))
	 ;1 Restore user timeout to be used with established connection*
	 (setf (send connection :user-timeout-handler) default-timeout-handler)
	 (setf (send stream :timeout) timeout-after-open))
      (error error-object)
      (:NO-ERROR stream))))

;1-------------------------------------------------*
;1 Let the TCP-STREAM medium know about UNIX*
;1-------------------------------------------------*

(net:define-stream-type 4:unix-translating-input-character-stream *'(:input :unix) :tcp-stream)
(net:define-stream-type 4:unix-translating-output-character-stream *'(:output :unix) :tcp-stream)
(net:define-stream-type 4:unix-translating-character-stream *'(:bidirectional :unix) :tcp-stream)