(in-package 'USER)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Routines to support socket-based networking for the agent    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(proclaim '(optimize (compilation-speed 0)))

;;;;
;;; Some defines:
;;;;
;;;
;; Taken from /usr/include/errno.h 
;;;
(setf ewouldblock 35)
;;;
;; ...from /usr/include/sys/ioctl.h
(setf fionbio -2147195266)		; Note that this value isn't
;; defined explicitly in that file, but rather is defined in terms of
;; a preprocessor function. I obtained the value by writing a tiny C
;; program which includes the file and prints the value of the FIONBIO
;; preprocessor macro. (See find-nb-val.c)
;;;
;;;
;(if (not (boundp 'agent-control-port)) ;outdated
;    (load "/ahi/lisp/dispatch"))
;; this loads the necessary SETFs to contact the correct ports on the
;; dispatcher.
;;;
;;; History: Dave Berger    '91
;;;          Carl Sparrell  '93 mods
;;;          Kris Thorisson Spring '95 mods
;;;
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set up a foreign buffer to pass network data to. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun setup-foreign-buffer ()        ;This fun called at end.
  (setf foreign-buf			; Create buffer for trans-
	(malloc-foreign-pointer		; ferring data via read/write
	 :type '(:pointer (:array :character (16300))))) ;
  (setf foreign-strng			; Make a copy w/ correct type
	(make-foreign-pointer		; to be passed to those functions
	 :address (foreign-pointer-address foreign-buf)
	 :type '(:pointer :character)))
  )


(defun receive-char-no-hang (sock)
  "Read a character, if one is available, from the specified socket
   and return it. If none is available, return nil right away without
   blocking. If an error occurs return nil."
  (set-nonblock sock)			; Prepare sock. for non-
  (receive-buf sock 1))			; blocking read and do it.


(defun receive-buf (sock num)
  "Do the read assuming blocking i/o has previously been set or
   cleared as desired. Return the string if valid, or nil otherwise."
  (let ((out			
	 (handle-socket-read sock num))) ; and read a character
    (if (= 0 (car out))			 ; 0 indicates no error
	(aref (cadr out) 0)		 ; Return a character.  
      nil)))


(defun receive-char (sock)
  "Read a character, blocking if none is available, from the specified
   socket and return it. Return nil if an error occurs."
  (set-block sock)			; Prepare socket for
  (receive-buf sock 1))			; blocking read and do it.
 
     
(defmacro make-growable-str (len)
  "Create an unitialized string of length `len' which is adjustable
   and has a fill-pointer. The fill-pointer is set to zero so the string
   initially appears empty."
  `(make-array  ,len  :element-type 'string-char
		:adjustable t  :fill-pointer 0))

(defmacro make-growable-list (len)
  "Create an unitialized string of length `len' which is adjustable
   and has a fill-pointer. The fill-pointer is set to zero so the string
   initially appears empty."
  `(make-array  ,len  :element-type 'symbol
		:adjustable t  :fill-pointer 0))


(defun receive-line (sock)
  "Read a line--i.e., the entire string preceeding a newline--from the
   specified socket and return it. "
  (set-block sock)			; Prepare socket for
  (do					;   blocking read.
   ((done nil) out			; Loop reading characters.
    (strng (make-growable-str 80)))
   (done strng)				; Return the string at end.
   (setf				; Read a character and
    out (handle-socket-read sock 1))	; store outcome in `out'.
   (cond
    ((null (cadr out))			; null indicates error
     (setf done t 
	   strng nil))   	        ; Return w/ nil string.
    ((if (characterp (cadr out))
	 (if (eq (character (cadr out)) #\Newline)   ; the line is complete
	     (setf done t))))       	; Establish that loop is over.
    (t					; Otherwise, append the
     (vector-push-extend		; character to the string
      (character (cadr out))		; and allow the loop to
      strng))))			        ; continue.
  )

(defun receive-line-no-hang (sock)
  "Read a string preceeding a newline. 
   We assume that there is something to read on the socket."
  (set-nonblock sock)		
  (let ((in1 (handle-socket-read sock 1)))
    (cond
     ((equal (cadr in1) "")                 ;if there is nothing on the socket,
      nil)                                  ; return nil.
     ((eq (character (cadr in1)) #\Newline) ;or if in1=cariage return.
      (cadr in1))                           ;return cr.
     (t               ;else, get rest of line, adding in1 to its beginning.
      (let ((strng (make-growable-str 80)))   
	(vector-push-extend (character (cadr in1)) strng)
	(set-block sock)
	(do		         
	 ((done nil) out)			 
	 (done strng)                       ; Return the string at end.
	 (setf				    ; Read a character and
	  out (handle-socket-read sock 1))  ; store outcome in `out'.
	 (cond
	  ((null (cadr out))		    ; null indicates error
	   (setf done t 
		 strng nil))   	            ; Return w/ nil string.
	  ((eq (character (cadr out)) #\Newline)   
	   (setf done t))
	  (t					
	   (vector-push-extend		
	    (character (cadr out))
	    strng)))
	 ))))
    ))


(defun get-list-from-sock (sock)
  (let ((in (receive-line-no-hang sock)))
    (if (null in) in
      (read-from-string in))))

(defun transmit-buf (sock strng)
  "Transmit a character-string through a given socket."
  (setf (foreign-string-value		; Copy the string into the
	 foreign-strng) strng)		; transmission buffer
  (set-block sock)			; Prepare sock for blocking
  (let ((out (handle-socket-write	; write and transmit buf,
	      sock (length strng))))	; storing result.
    (set-nonblock sock)
    (if (= (car out) 0)			; 0 indicates no error
	(cadr out)			; Return # bytes sent
      nil)))

(defun handle-socket-write (sock sz)
  "Do the write command to socket and check for error condition. 
   See `handle-socket-error'."
  (let* ((stat (write-socket		; Write *sz* chars. 
		sock foreign-strng sz)) ; Store val. or errno.
	 (error-num (err)))
    (if (< stat 1)			; Situation abnormal...
	(handle-socket-error stat error-num) ; Deal with.
      (list 0 stat))))			; Return # chars. written.

(defun handle-socket-read (sock sz)
  "Do the read command from socket and check for an error condition.
   See `handle-socket-error'."
  (let* ((stat (read-socket sock foreign-strng sz)) ; read *sz* chars.
	 (error-num (err)))
    (cond ((or (< stat 0) (and (= stat 0) (> sz 1)))	; Situation abnormal...
	   (handle-socket-error stat error-num)) ; Deal with.
	  ((= stat 0)
	   (format t "WARNING: Stat = ~d   E: ~d~%>~a<~%" stat error-num 
		   (foreign-string-value foreign-strng))
	   (list				; Return data.
	    0 (subseq			; Return only the portion
	       (foreign-string-value		; which is valid (i.e.,)
		foreign-strng) 0 1)))
	  ((> stat sz)
	   (format t "WARNING: Stat = ~d   E: ~d~%>~a<~%" stat error-num 
		   (foreign-string-value foreign-strng))
	   (if (= sz 1)
	       (list				
		0 (subseq			
		   (foreign-string-value	
		    foreign-strng) 0 1))
	     (list -1 nil)))
	  (t
	   (list				; Return data.
	    0 (subseq			; Return only the portion
	       (foreign-string-value		; which is valid (i.e.,)
		foreign-strng) 0 stat))))))

(defun handle-socket-error (stat error-num)
  "Handle the errors ensuing from a socket read or write. This routine
   should not be called if stat > 0.

   1st entry  | meaning
   -----------+--------
   -1           call return value = 0 (should indicate EOF).
    0            No error. 
   nn           Unix system error (2nd entry will be nil)."

  (if (= -1 stat)			; Indicates read-error
      (cond
       ((= error-num ewouldblock)	; if no data avail,
	(list ewouldblock ""))		; return empty string.
       (t				; If some other error,
	(warn "Error [~D] occurred reading from socket [~D]~%"
	      error-num socket1)	; Notify that error occured,
	(list error-num nil)))		; but lamely do nothing...
					; Indicates EOF.
    (list -1 nil)))			; Return indication of EOF.

#|
;;; The following updated by CJS on 4/10/93.  They were choking on
;;; 0,1 not being passed as a character

(defun set-block (sock)
  "Set the selected socket up for blocking I/O. (See io-block-ctl)"
  (io-block-ctl sock (character 0)))		; 0 means disable nonblock.
(defun set-nonblock (sock)
  "Set the selected socket up for non-blocking I/O. (See io-block-ctl)"
  (io-block-ctl sock (character 1)))		; 1 means enable nonblock.
|#


(defun set-block (sock)
  "Set the selected socket up for blocking I/O. (See io-block-ctl)"
  (io-block-ctl sock 0))      ; 0 means disable nonblock.
(defun set-nonblock (sock)
  "Set the selected socket up for non-blocking I/O. (See io-block-ctl)"
  (io-block-ctl sock 1))		; 1 means enable nonblock.


(let ((buf				; This `let' allows buf to be
       (malloc-foreign-pointer		; local and static to this
	:type				; function. Malloc buf to be
	'(:pointer :signed-32bit))))	; a pointer to an integer.
;;  (setf (foreign-pointer-type		; Modify the type of the new
;;	 buf) '(:pointer :character))	; pointer to match that of the
  (defun io-block-ctl			; require ioctl(2) param.
       (sock &optional (op nil op-p))	; Make `op' an optional param.
    (cond				; Check if op was passed.
     (op-p				; If so, we have an ioctl
      (setf (foreign-value buf) op	; request: set contents of buf
	    (foreign-pointer-type buf)	; appropriately and do the
	    '(:pointer :character))	; ioctl.
      (ioctl sock fionbio buf)		;
      (setf (foreign-pointer-type buf)	; Set the pointer's type back
	    '(:pointer :signed-32bit)))	; to int. (its normal value).
     (t buf))))				; Otherwise return buf, so it
					; can be accessed globally
					; (e.g., for `free'ing).

(setup-foreign-buffer)