;;;
;;; sockets.cl
;;;
;;; An interface to the BSD socket library, together with some
;;; functions for doing simple client and server operations.  This
;;; code is based on the information in Internetworking with TCP/IP,
;;; volume III, Client-Server Programming and Applications, by Douglas
;;; Comer and David Stevens, and also assisted by studying the ipc.cl
;;; example code from Allegro CL, Franz, Inc.
;;;
;;; Still to do: better handling of errors, incorporate suggestions
;;; from last chapter of Comer on servers, e.g., about controlling
;;; tty, directory, umask, process group, mutual exclusion, handling
;;; of stdin, stdout, stderr, handling signals, logging.
;;;
;;; 31-Dec-1996 I. Kalet created
;;; 14-Apr-1997 I. Kalet use int-value instead of Allegro
;;; sys:memref-int function, less implementation dependent.
;;; 29-Dec-1998 I. Kalet name changes and other stylistic edits.
;;;
;;;------------------------------------------------

(defpackage :socket
  (:nicknames "SO")
  (:use :common-lisp)
  (:export "HOST-ADDRESS"
	   "MAKE-SOCKADDR-IN"
	   "TCP-ACCEPT" "TCP-CLOSE" "TCP-CONNECT" "TCP-PASSIVE-SOCKET"
	   "TCP-PORT-NUMBER" "TCP-READ" "TCP-SERVER" "TCP-SHUTDOWN"
	   "TCP-WRITE"
	   ))

(in-package :socket)

;;;------------------------------------------------

(defconstant *af-inet* 2
  "The AF_INET constant from /usr/include/sys/socket.h")

(defconstant *pf-inet* *af-inet*
  "The PF_INET constant from /usr/include/sys/socket.h")

(defconstant *sock-stream* #+svr4 2 #-svr4 1
  "The SOCK_STREAM constant from /usr/include/sys/socket.h")

(defconstant *inaddr-any* 0
  "The INADDR_ANY constant from /usr/include/netinet/in.h")

;;;------------------------------------------------------------------
;;; The following syntax for defining C structs and foreign functions
;;; and loading the libraries is specific to Allegro CL.
;;;
;;; The actual structures and functions are described in Appendix 1 of
;;; Comer and Stevens, mentioned above.
;;;------------------------------------------------------------------

;;;------------------------------------------------
;;; define the Internet data structures - C structs
;;;------------------------------------------------

(ff:def-c-type sockaddr-in                    ; from /usr/include/netinet/in.h
	       :struct
	       (family :unsigned-short)                 ; short sin_family
	       (port :unsigned-short)                   ; u_short sin_port
	       (addr :unsigned-int)                  ; struct in_addr sin_addr
	       (zero 8 :char)                           ; char sin_zero[8]
	       )

(defconstant *sockaddr-in-len* (ff::cstruct-length 'sockaddr-in)
  "The length in bytes of the sockaddr-in data structure, used in some
of the socket function calls")

(ff:def-c-type (hostent :in-foreign-space)         ; from /usr/include/netdb.h
	       :struct
	       (name * :char)                           ; char *h_name
	       (aliases * * :char)                      ; char **h_aliases
	       (addrtype :int)                          ; int h_addrtype
	       (length :int)                            ; int h_length
	       (addr * * :char)                         ; char **h_addr_list
	       )

(ff:def-c-type (servent :in-foreign-space)         ; from /usr/include/netdb.h
	       :struct
	       (name * :char)                           ; char *s_name
	       (aliases * * :char)                      ; char **s_aliases
	       (port :signed-int)                       ; int s_port
	       (proto * :char)                          ; char *s_proto
	       )

;;;------------------------------------------------
;;; this is a hack to pass an unsigned int by ref.
;;; (int-value x) returns the value,
;;; (setf (int-value x) y) updates the value,
;;; and x gives the address of the value.
;;;------------------------------------------------

(ff:def-c-type int :struct (value :unsigned-int))

;;;------------------------------------------------
;;; load the socket library functions
;;;------------------------------------------------

(defparameter *socket-funcs*
  (mapcar #'ff:convert-to-lang
      '("socket" "connect" "bind" "listen" "accept" "read" "write" "close"
	"shutdown" "gethostbyname" "getservbyname")))

(eval-when (load eval compile)
  (unless (dolist (name *socket-funcs* t)
	    (unless (ff:get-extern-code-address name)
	      (return nil)))
    (format t "~&; socket: Loading networking routines from C library ...")
    (unless
      (load "" :verbose nil                    ; this is the non-DLFCN version
	    :unreferenced-lib-names *socket-funcs*)
      (error "socket: foreign load failed"))
    (format t " done.")))

;;;------------------------------------------------------------------
;;; Now define to lisp all the foreign functions.  The default type
;;; conversion for passing arguments from lisp to C works for all.
;;;
;;; All the functions return integer values.  For two of them,
;;; gethostbyname and getservbyname, if the value is not 0, it is
;;; actually a pointer to a c-struct, type hostent for gethostbyname,
;;; or type servent for getservbyname.  The accessor functions
;;; generated by the def-c-type forms will work correctly with this,
;;; with NO special hacking.
;;;------------------------------------------------------------------

(ff:defforeign 'socket :unconverted-entry-name "socket")

(ff:defforeign 'connect :unconverted-entry-name "connect")

(ff:defforeign 'bind :unconverted-entry-name "bind")

;;; listen is already in the common-lisp package - see CLTL2 p. 574
(ff:defforeign 'tcp-listen :unconverted-entry-name "listen")

(ff:defforeign 'accept :unconverted-entry-name "accept")

;;; read, write and close are already in the common-lisp package too

(ff:defforeign 'tcp-read :unconverted-entry-name "read")

(ff:defforeign 'tcp-write :unconverted-entry-name "write")

(ff:defforeign 'tcp-close :unconverted-entry-name "close")

(ff:defforeign 'tcp-shutdown :unconverted-entry-name "shutdown")

(ff:defforeign 'gethostbyname :unconverted-entry-name "gethostbyname")

(ff:defforeign 'getservbyname :unconverted-entry-name "getservbyname")

;;;------------------------------------------------------------------
;;; these work in Linux, but not HP-UX - for HP-UX prefix the
;;; unconverted-entry-name by lisp_ as in lisp_htons
;;;------------------------------------------------------------------

(ff:defforeign 'htons :unconverted-entry-name "htons")

(ff:defforeign 'htonl :unconverted-entry-name "htonl")

(ff:defforeign 'ntohs :unconverted-entry-name "ntohs")

(ff:defforeign 'ntohl :unconverted-entry-name "ntohl")

;;;------------------------------------------------
;;; Now the actual network functions
;;;------------------------------------------------

(defun host-address (host)

  "host-address host

returns the 32 bit integer host address of host, in network byte
order.  The host parameter can be either an integer host number in
host byte order, or a string, an internet domain name."

  (cond ((integerp host) (htonl host))                  ; the easy case
	((stringp host) (let ((tmp (gethostbyname host)))
			  ;; tmp is a pointer to a hostent c-struct
			  ;; a pointer value of 0 means lookup failed
			  (if (= tmp 0)
			      (error "Unknown host: ~S" host))
			  (if (= 4 (hostent-length tmp))
			      ;; this little hack is needed because
			      ;; the hostent structure has in this
			      ;; slot a pointer to a pointer.  The
			      ;; ipc.cl code says the second level of
			      ;; indirection is system dependent but
			      ;; Comer defines it this way in general.
			      (int-value (int-value (hostent-addr tmp)))
			      (error
				"host-address: Host address length not 4"))))
	(t (error "host-address: Host not a string or integer"))))

;;;------------------------------------------------

(defun tcp-port-number (port)

  "tcp-port-number port

returns the port number in network byte order for port, which can be
either an integer port number or a string naming a well known TCP
service."

  (cond ((integerp port) (htons port))                  ;; the easy case
	((stringp port) (let ((tmp (getservbyname port "tcp")))
			  ;; tmp is a pointer to a servent c-struct
			  ;; a pointer value of 0 means lookup failed
			  (if (= tmp 0)
			      (error
				"tcp-port-number: Unknown service: ~S" port)
			      (servent-port tmp))))
	(t (error "tcp-port-number: Port not a string or integer"))))

;;;------------------------------------------------

(defun tcp-connect (host service)

  "tcp-connect host service

returns a socket descriptor for a TCP connection to the specified
remote host and service, where host can be a host domain name or IP
address, and service is either the name of a well known service or a
port number for the desired service."

  (let ((dest-addr (make-sockaddr-in))              ; from C struct definition
	(sock (socket *pf-inet* *sock-stream* 0))
	)
    (if (< sock 0) (error "tcp-connect: Cannot create TCP socket"))
    (setf (sockaddr-in-addr dest-addr) (host-address host)
	  (sockaddr-in-port dest-addr) (tcp-port-number service)
	  (sockaddr-in-family dest-addr) *af-inet*)
    (if (= (connect sock dest-addr *sockaddr-in-len*) 0)
	sock                                ;; connect returns 0 if successful
	(error "tcp-connect: Cannot connect to ~S/~S" host service))))

;;;------------------------------------------------

(defun tcp-passive-socket (port qlen)

  "tcp-passive-socket port qlen

returns a socket descriptor for a socket that is ready to accept
incoming connection requests, for the specified port, which can be an
integer or a string naming a well known service.  The qlen parameter
is an integer specifying how many connection requests can be queued
before rejecting additional requests."

  (let ((local-addr (make-sockaddr-in))             ; from C struct definition
	(sock (socket *pf-inet* *sock-stream* 0))
	)
    (if (< sock 0) (error "tcp-passive-socket: Cannot create TCP socket"))
    (setf (sockaddr-in-addr local-addr) *inaddr-any*
	  (sockaddr-in-port local-addr) (tcp-port-number port)
	  (sockaddr-in-family local-addr) *af-inet*)
    (if (< (bind sock local-addr *sockaddr-in-len*) 0)
	(error "tcp-passive-socket: Bind failed"))
    (if (< (tcp-listen sock qlen) 0)
	(error "tcp-passive-socket: Listen failed")
	sock)))

;;;------------------------------------------------

(defun tcp-accept (sock remote-addr)

  "tcp-accept sock remote-addr

waits for a connection request on the socket specified by socket
descriptor sock, using the preallocated caller-provided sockaddr-in
structure, remote-addr, to store information about the remote client
when the connection request is accepted.  Returns a socket descriptor
for the new connection."

  (let ((length-ptr (make-int)))         ;; pass by reference instead of value
    (setf (int-value length-ptr) *sockaddr-in-len*)
    (accept sock remote-addr length-ptr)))

;;;------------------------------------------------

(defun tcp-server (port qlen app-fn)

  "tcp-server port qlen app-fn

implements the iterative connection-oriented server algorithm of
Chapter 10 of Comer and Stevens vol. 3.  The port parameter is either
a number or a string naming a well known service, qlen is the length
of the connection request queue to allow, and app-fn is a function of
one parameter, the socket descriptor of an accepted connection,
implementing the server's protocol, e.g., the daytime function.  The
tcp-server function does not return unless the accept socket routine
returns an invalid descriptor."

  (let ((remote (make-sockaddr-in))                 ; from C struct definition
	(sock (tcp-passive-socket port qlen))
	(descriptor))
    (loop
      (setf descriptor (tcp-accept sock remote))
      (if (< descriptor 0)
	  (error "tcp-server: Accept failed")
	  (progn
	    (funcall app-fn descriptor)
	    (tcp-close descriptor))))))

;;;------------------------------------------------

(defun pp-inet-addr (addr strm)

  "PP-INET-ADDR addr strm

writes out IP address addr, an integer, in dot notation, to stream
strm.  Mainly useful for debugging.  From Allegro ipc.cl code,
assumes host byte order."

  (format strm "[~11,1,1,'.<~2,'0D~;~2,'0D~;~2,'0D~;~2,'0D~>]"
	  (ldb (byte 8 24) addr)
	  (ldb (byte 8 16) addr)
	  (ldb (byte 8  8) addr)
	  (ldb (byte 8  0) addr)))

;;;------------------------------------------------
;;; End.