(in-package 'USER)

;;
; Define some of the macros useful for socket related commands.
; See /usr/include/sys/socket.h, from which they are taken.
;
; HISTORY: 
;    Dave Berger (but don't tell anyone)
;    modified by K.R.Thorisson Nov/Dec 1994.
;         and by D. Berger & K.R.Th. May '95.
;;

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

(setf af-inet-define 2)			;; For the ADDRESS FAMILY param
(setf sock-stream-define 1)		;; For the SOCKET TYPE param

; ... and /usr/include/netinet/in.h

(setf inaddr-any-define #x00000000)


;;;
;; Define the foreign structures.
;;;

;; for  struct sockaddr  (found in /usr/include/sys/socket.h)
;;
;    struct sockaddr {                                                         
;            u_short sa_family;         /* address family */             
;            char    sa_data[14];       /* up to 14 bytes of direct address */
;    };                                                                       
;;

(def-foreign-struct (sockaddr
		     (:alignment (:modulus 4)))
  (sa_family  :type :unsigned-16bit)
  (sa_data    :type (:array :character (14))))

;; for  struct in_addr  (modified from /usr/include/sys/socket.h)
;;
;    struct in_addr {
;            u_long s_addr;
;    };
;;

(def-foreign-struct (in_addr
		     (:alignment (:modulus 4)))
  (s_addr     :type :unsigned-32bit))

;; for  struct sockaddr_in  (found in /usr/include/netinet/in.h)
;;
;    struct sockaddr_in {             
;            short   sin_family;      
;            u_short sin_port;        
;            struct  in_addr sin_addr;
;            char    sin_zero[8];     
;    };                               
;;

(def-foreign-struct (sockaddr_in
		     (:alignment (:modulus 4)))
  (sin_family  :type :signed-16bit)
  (sin_port    :type :unsigned-16bit)
  (sin_addr    :type in_addr)
  (sin_zero    :type (:array :character (8))))



;;;
;; Define the foreign interfaces.
;;;


;; for the accept system-call
;;
;    #include <sys/types.h>        
;    #include <sys/socket.h>       
;
;  int accept(int s, struct sockaddr *addr, int *addrlen)
;

(def-foreign-function (accept-socket-conn
		       (:language :c)
		       (:name "accept")
		       (:return-type :signed-32bit))
  "Accept a connection to a created and LISTENing socket."
  (socket-descriptor :signed-32bit)
  (socket-address (:pointer sockaddr))
  (address-length (:pointer :signed-32bit)))


;; for the socket system-call.
;;
;    #include <sys/types.h>        
;    #include <sys/socket.h>       
;                                  
;    s = socket(af, type, protocol)
;    int s, af, type, protocol;    
;;

(def-foreign-function (create-bsd-socket
		       (:language :c)
		       (:name "socket")
		       (:return-type :signed-32bit))
  "Create an endpoint for communication and return a descriptor, 
   see also man 2 socket."
  (address-family-type :signed-32bit)
  (socket-type :signed-32bit)
  (protocol :signed-32bit))


;; for the bind system-call.
;;
;  #include <sys/types.h>  
;  #include <sys/socket.h> 
;                          
;  bind(s, name, namelen)  
;  int s;                  
;  struct sockaddr *name;  
;  int namelen;            
;;

(def-foreign-function (bind-socket
		       (:language :c)
		       (:name "bind")
		       (:return-type :signed-32bit))
  "Bind a socket to an address. 
   This must be done before the socket can be used."
  (socket-descriptor :signed-32bit)
  (socket-address (:pointer sockaddr))
  (address-length :signed-32bit))


;; for the connect system-call.
;;
;  #include <sys/types.h>   
;  #include <sys/socket.h>  
;                           
;  connect(s, name, namelen)
;  int s;                   
;  struct sockaddr *name;   
;  int namelen;             
;;

(def-foreign-function (connect-socket
		       (:language :c)
		       (:name "connect")
		       (:return-type :signed-32bit))
  "Request a connection to a remote socket (which must be LISTENing).
   The local socket must be bound."
  (socket-descriptor :signed-32bit)
  (socket-address (:pointer sockaddr))
  (address-length :signed-32bit))


;; for the listen system-call
;;
;   #inlcude sys/types.h
;   #inlcude sys/socket.h
;
; int listen(int s, int backlog)
;    
;   backlog = max length of pending connections

(load-foreign-libraries '("listen") '("-lc"))

(def-foreign-function (listen-for-conn
		       (:language :c)
		       (:name "listen")
		       (:return-type :signed-32bit))
  "Listen on a created socket."
  (socket-descriptor :signed-32bit)
  (socket-backlog    :signed-32bit))


;; for the write system-call.
;;
;    write (fd, buf, nbytes)    
;    int fd;                    
;    char *buf;                 
;    int nbytes;                
;;

(def-foreign-function (write-socket
		       (:language :c)
		       (:name "write")
		       (:return-type :signed-32bit))
  "Write the contents of a buffer of bytes to an IO device. 
   The device is specified by the descriptor argument."
  (descriptor  :signed-32bit)
  (buffer     (:pointer :character))
  (buf-size    :signed-32bit))


;; for the read system-call.
;;
;    cc = read (d, buf, nbytes)    
;    int cc, d;                    
;    char *buf;                 
;    int nbytes;                
;;

(def-foreign-function (read-socket
		       (:language :c)
		       (:name "read")
		       (:return-type :signed-32bit))
  "Read bytes from an IO device into a buffer. 
   The device is specified by the descriptor argument."
  (descriptor  :signed-32bit)
  (buffer     (:pointer :character))
  (buf-size    :signed-32bit))


;; for the close system-call.
;;
;  close(fd)
;  int fd;  
;;
(def-foreign-function (close-socket
		       (:language :c)
		       (:name "close")
		       (:return-type :signed-32bit))
  "Delete a socket descriptor (or other unix file descriptor)."
  (descriptor :signed-32bit))


;; for the ioctl system-call.
;;
;  #include <sys/ioctl.h> 
;                         
;  ioctl(d, request, argp)
;  int d, request;        
;  char *argp;            
;;

(def-foreign-function (ioctl
		       (:language :c)
		       (:name "ioctl")
		       (:return-type :signed-32bit))
  "The generic I/O configuration/control routine."
  (descriptor :signed-32bit)
  (request    :signed-32bit)
  (argp       (:pointer :character)))

;; for the perror system-call.
;;
;
;; for the htonl, htons, ntohl & ntohs library calls.
;;
;    #include <sys/types.h>       
;    #include </bsd/netinet/in.h> 
;                                 
;    netlong = htonl(hostlong);   
;    u_long netlong, hostlong;    
;                                 
;    netshort = htons(hostshort); 
;    u_short netshort, hostshort; 
;                                 
;    hostlong = ntohl(netlong);   
;    u_long hostlong, netlong;    
;                                 
;    hostshort = ntohs(netshort); 
;    u_short hostshort, netshort; 
;;

(def-foreign-function (htonl
		       (:language :c)
		       (:name "htonl")
		       (:return-type :unsigned-32bit))
  "Convert bytes of a long-integer from `host' to `network' order."
  (host-val :unsigned-32bit))
;
(def-foreign-function (htons
		       (:language :c)
		       (:name "htons")
		       (:return-type :unsigned-32bit))
  "Convert bytes of a short-integer from `host' to `network' order."
  (host-val :unsigned-32bit))
;
(def-foreign-function (ntohl
		       (:language :c)
		       (:name "htonl")
		       (:return-type :unsigned-32bit))
  "Convert bytes of a long-integer from `network' to `host' order."
  (net-val :unsigned-32bit))
;
(def-foreign-function (ntohs
		       (:language :c)
		       (:name "ntohs")
		       (:return-type :unsigned-32bit))
  "Convert byte of a short-integer from `network' to `host' order."
  (net-val :unsigned-32bit))

(load-foreign-libraries '("listen") '("-lc"))

;;;
;; Routines
;;;

;; ERR
;; To print the value of foreign, external variable "errno".
;
(defun err ()
  (foreign-value (foreign-variable-pointer "errno")))
;
; For this to work, "errno"'s pointer-type needs to be set:
(setf (foreign-pointer-type (foreign-variable-pointer "errno"))
      '(:pointer :signed-32bit))

;; INIT-SOCKET
;; To help open sockets
;
;;
; Note: this procedure is bad lisp; it potentially mutates globals,
; and it uses C-'return()' style control constructs... Fix it
; Thanks.

(defun init-socket (rhost port)
  "Take care of part of the job of opening a stream.
   Create the necessary data structures, find the correct internet
   address (at this point just by checking a list) and call socket
   and bind."
  (setf socket1 (create-bsd-socket af-inet-define sock-stream-define 0))
  (if (< socket1 1) (return-from init-socket (list "create" (err))))
  (setf
   addr-loc (make-sockaddr)
   in-addr-loc (make-foreign-pointer
		:type '(:pointer sockaddr_in)
		:address (foreign-pointer-address addr-loc))

   addr-rem (make-sockaddr)
   in-addr-rem (make-foreign-pointer
		:type '(:pointer sockaddr_in)
		:address (foreign-pointer-address addr-rem))
   
;   (sockaddr-sa_family addr-loc) af-inet-define
;   (sockaddr_in-sin_port in-addr-loc) 0
;   (in_addr-s_addr (sockaddr_in-sin_addr in-addr-loc)) inaddr-any-define
   
   (sockaddr-sa_family addr-rem) af-inet-define
   (sockaddr_in-sin_port in-addr-rem) (htons port)
   (in_addr-s_addr (sockaddr_in-sin_addr in-addr-rem))
   (hostname-to-net rhost)
    )
  (if (= -1
	 (bind-socket socket1 addr-loc (foreign-size-of addr-loc)))
      (return-from init-socket (list "bind err:" (err))))
  socket1)

(defun open-socket (rhost port)
  "Create and connect a socket to a given port on a given host. 
   First call init-socket and then connect."
  (let ((sock (init-socket rhost port)))
    (if	(listp sock)			; Indicates error from
	(return-from			; init-socket, so abort from
	 open-socket			; open-socket.
	 (append '("INIT-SOCKET:") sock)))
    (if (=
	 -1				; Indicates error from connect
	 (connect-socket sock addr-rem (foreign-size-of addr-rem)))
	(return-from open-socket (list "connecting err:" (err) sock)))
    sock))

(defun wait-for-socket (port)
  "Create a listening socket.
   Take care of part of the job of creating a stream.
   Create the necessary data structures, and call socket and bind,
   loop until a valid connection is requested remotely."
  (setf socket1 (create-bsd-socket af-inet-define sock-stream-define 0))
  (if (< socket1 1) (return-from wait-for-socket (list "create err" (err))))
  (setf
   addr-loc (make-sockaddr)
   in-addr-loc (make-foreign-pointer
		:type '(:pointer sockaddr_in)
		:address (foreign-pointer-address addr-loc))
   
   addr-rem (make-sockaddr)
   in-addr-rem (make-foreign-pointer
		:type '(:pointer sockaddr_in)
		:address (foreign-pointer-address addr-rem))
   
   size-ptr (make-foreign-pointer :type '(:pointer :signed-32bit))
   (sockaddr-sa_family addr-loc) af-inet-define
   (sockaddr_in-sin_port in-addr-loc) (htons port)
   )
  (if (= -1
	 (bind-socket socket1 addr-loc (foreign-size-of addr-loc)))
      (return-from wait-for-socket (list "bind err" (err))))
  (listen-for-conn socket1 1)
;  (set-block socket1)
;  (read-char)
  (setf socket2 -1)
  (loop while (eq socket2 -1) do  ;loop until socket id is valid
        (progn
          (setf socket2 (accept-socket-conn socket1 addr-rem size-ptr))
          (sleep 1)))
  socket2
  )

#|
    (if (= -1 (listen sock))
	(return-from wait-for-socket (append '("LISTEN:") sock))
      (
    (if (=
	 -1				; Indicates error from connect
	 (connect-socket sock addr-rem (foreign-size-of addr-rem)))
	(return-from open-socket (list "connecting:" (err) sock)))
    sock))
|#

;;
;; To get the #xNNNNNN numbers, use getaddr in /ahi/bin/machine_type
;;
;; New IP addresses put in place 7/17 1995  -K.R.Th.
;;

(defun hostname-to-net (hostn)
  (htonl
   (cdr
    (assoc
     hostn
     '(
       ("leon"                . #x52135512)
       ("spot"                . #x4d135512)
       ("spud"                . #x50135512)
       ("spam"                . #x4e135512)  
       ("splotch"             . #x1255134b)
       ("sparta"              . #x4f35512)
       ("spork"               . #x4a135512)
       ("spike"               . #x51135512)
       ("paradise"            . #x56015512)
       ("spleen"              . #x4c135512)
       ) 
     :test #'string-equal))))