l1-sockets.lisp with initial ipv6 support

gistfile1.lisp

;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;;   Copyright (C) 2001-2009 Clozure Associates
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")



;;; basic socket API
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(MAKE-SOCKET
	    ACCEPT-CONNECTION
	    DOTTED-TO-IPADDR
	    IPADDR-TO-DOTTED
	    IPADDR-TO-HOSTNAME
	    LOOKUP-HOSTNAME
	    LOOKUP-PORT
	    ;;with-pending-connect
	    RECEIVE-FROM
	    SEND-TO
	    SHUTDOWN
	    ;;socket-control
	    SOCKET-OS-FD
	    REMOTE-HOST
	    REMOTE-PORT
	    REMOTE-FILENAME
	    LOCAL-HOST
	    LOCAL-PORT
	    LOCAL-FILENAME
	    SOCKET-ADDRESS-FAMILY
	    SOCKET-CONNECT
	    SOCKET-FORMAT
	    SOCKET-TYPE
	    SOCKET-ERROR
	    SOCKET-ERROR-CODE
	    SOCKET-ERROR-IDENTIFIER
	    SOCKET-ERROR-SITUATION
	    SOCKET-CREATION-ERROR
	    SOCKET-CREATION-ERROR-CODE
	    SOCKET-CREATION-ERROR-IDENTIFIER
	    SOCKET-CREATION-ERROR-SITUATION
	    WITH-OPEN-SOCKET))
  #+windows-target
  (defmacro check-winsock-error (form)
    (let* ((val (gensym)))
      `(let* ((,val ,form))
        (if (or (< ,val 0) (eql ,val #xffffffff))
          (%get-winsock-error)
          ,val))))
  (defmacro check-socket-error (form)
    #+windows-target `(check-winsock-error ,form)
    #-windows-target `(int-errno-call ,form))
  )


#+windows-target
(defun %get-winsock-error ()
  (- (#_WSAGetLastError)))

;;; The PPC is big-endian (uses network byte order), which makes
;;; things like #_htonl and #_htonl no-ops.  These functions aren't
;;; necessarily defined as functions in some header files (I'm sure
;;; that that either complies with or violates some C standard), and
;;; it doesn't seem to make much sense to fight that to do ff-calls
;;; to a couple of identity functions.

#+big-endian-target
(progn
  (defmacro HTONL (x) x)
  (defmacro HTONS (x) x)
  (defmacro NTOHL (x) x)
  (defmacro NTOHS (x) x))

#+little-endian-target
(progn
  (declaim (inline %bswap32 %bswap16))
  (defun %bswap32 (x)
    (declare (type (unsigned-byte 32) x))
    (%swap-u32 x))
  (defun %bswap16 (x)
    (declare (type (unsigned-byte 16) x))
    (%swap-u16 x))
  (defmacro HTONL (x) `(%bswap32 ,x))
  (defmacro HTONS (x) `(%bswap16 ,x))
  (defmacro NTOHL (x) `(%bswap32 ,x))
  (defmacro NTOHS (x) `(%bswap16 ,x)))

(defparameter *default-socket-character-encoding*
  nil)

(defmethod default-character-encoding ((domain (eql :socket)))
  *default-socket-character-encoding*)
  

;;; On some (hypothetical) little-endian platform, we might want to
;;; define HTONL and HTONS to actually swap bytes around.

(defpackage "OPENMCL-SOCKET"
  (:use "CL")
  (:import-from "CCL"
		"MAKE-SOCKET"
		"ACCEPT-CONNECTION"
		"DOTTED-TO-IPADDR"
		"IPADDR-TO-DOTTED"
		"IPADDR-TO-HOSTNAME"
		"LOOKUP-HOSTNAME"
		"LOOKUP-PORT"
		;;with-pending-connect
		"RECEIVE-FROM"
		"SEND-TO"
		"SHUTDOWN"
		;;socket-control
		"SOCKET-OS-FD"
		"REMOTE-HOST"
		"REMOTE-PORT"
		"REMOTE-FILENAME"
		"LOCAL-HOST"
		"LOCAL-PORT"
		"LOCAL-FILENAME"
		"SOCKET-ADDRESS-FAMILY"
		"SOCKET-CONNECT"
		"SOCKET-FORMAT"
		"SOCKET-TYPE"
		"SOCKET-ERROR"
		"SOCKET-ERROR-CODE"
		"SOCKET-ERROR-IDENTIFIER"
		"SOCKET-ERROR-SITUATION"
		"SOCKET-CREATION-ERROR"
		"SOCKET-CREATION-ERROR-CODE"
		"SOCKET-CREATION-ERROR-IDENTIFIER"
		"SOCKET-CREATION-ERROR-SITUATION"
		"WITH-OPEN-SOCKET")
  (:export  "MAKE-SOCKET"
	    "ACCEPT-CONNECTION"
	    "DOTTED-TO-IPADDR"
	    "IPADDR-TO-DOTTED"
	    "IPADDR-TO-HOSTNAME"
	    "LOOKUP-HOSTNAME"
	    "LOOKUP-PORT"
	    ;;with-pending-connect
	    "RECEIVE-FROM"
	    "SEND-TO"
	    "SHUTDOWN"
	    ;;socket-control
	    "SOCKET-OS-FD"
	    "REMOTE-HOST"
	    "REMOTE-PORT"
	    "REMOTE-FILENAME"
	    "LOCAL-HOST"
	    "LOCAL-PORT"
	    "LOCAL-FILENAME"
	    "SOCKET-ADDRESS-FAMILY"
	    "SOCKET-CONNECT"
	    "SOCKET-FORMAT"
	    "SOCKET-TYPE"
	    "SOCKET-ERROR"
	    "SOCKET-ERROR-CODE"
	    "SOCKET-ERROR-IDENTIFIER"
	    "SOCKET-ERROR-SITUATION"
	    "SOCKET-CREATION-ERROR"
	    "SOCKET-CREATION-ERROR-CODE"
	    "SOCKET-CREATION-ERROR-IDENTIFIER"
	    "SOCKET-CREATION-ERROR-SITUATION"
	    "WITH-OPEN-SOCKET"))

(define-condition socket-error (simple-stream-error)
  ((code :initarg :code :reader socket-error-code)
   (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier)
   (situation :initarg :situation :reader socket-error-situation)))

(define-condition socket-creation-error (simple-error)
  ((code :initarg :code :reader socket-creation-error-code)
   (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
   (situation :initarg :situation :reader socket-creation-error-situation)
   (remote-address :initform nil :initarg :remote-address :accessor socket-creation-error-remote-address)))

(defparameter *gai-error-identifiers*
  (list #$EAI_AGAIN :try-again
	#$EAI_FAIL :no-recovery
	#$EAI_NONAME :host-not-found))

(defvar *socket-error-identifiers*
  #-windows-target
  (list #$EADDRINUSE :address-in-use
	#$ECONNABORTED :connection-aborted
	#$ENOBUFS :no-buffer-space
	#$ENOMEM :no-buffer-space
	#$ENFILE :no-buffer-space
	#$ETIMEDOUT :connection-timed-out
	#$ECONNREFUSED :connection-refused
	#$ENETUNREACH :host-unreachable
	#$EHOSTUNREACH :host-unreachable
	#$EHOSTDOWN :host-down
	#$ENETDOWN :network-down
	#$EADDRNOTAVAIL :address-not-available
	#$ENETRESET :network-reset
	#$ECONNRESET :connection-reset
	#$ESHUTDOWN :shutdown
	#$EACCES :access-denied
	#$EPERM :access-denied)
  #+windows-target
  (list #$WSAEADDRINUSE :address-in-use
	#$WSAECONNABORTED :connection-aborted
	#$WSAENOBUFS :no-buffer-space
	#$ENOMEM :no-buffer-space
	#$ENFILE :no-buffer-space
	#$WSAETIMEDOUT :connection-timed-out
	#$WSAECONNREFUSED :connection-refused
	#$WSAENETUNREACH :host-unreachable
	#$WSAEHOSTUNREACH :host-unreachable
	#$WSAEHOSTDOWN :host-down
	#$WSAENETDOWN :network-down
	#$WSAEADDRNOTAVAIL :address-not-available
	#$WSAENETRESET :network-reset
	#$WSAECONNRESET :connection-reset
	#$WSAESHUTDOWN :shutdown
	#$EACCES :access-denied
	#$EPERM :access-denied)
  )


(declaim (inline socket-call))
(defun socket-call (stream where res)
  (if (< res 0)
    (socket-error stream where res nil)
    res))

#-windows-target
(defun %gai-strerror (err)
  (let ((p (#_gai_strerror err)))
    (if (%null-ptr-p p)
      (format nil "Unknown nameserver error ~d" err)
      (%get-cstring p))))

(defun get-error-address-info (info)
  (let* ((sockaddr (getf info :sockaddr)))
    (when sockaddr
      (cond
        ((= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
         (list (ntohl (pref sockaddr
                            #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                            #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))
               (ntohs (pref sockaddr :sockaddr_in.sin_port))))
        ((= #$AF_INET6 (pref sockaddr :sockaddr_in6.sin6_family))
         (list (_inet_ntop #$AF_INET6 sockaddr)
               (ntohs (pref sockaddr :sockaddr_in6.sin6_port))))
        #-windows-target
        ((= #$AF_UNIX (pref sockaddr :sockaddr_un.sun_family))
         (path-from-unix-address sockaddr))))))
               

        

                         
(defun socket-error (stream where errno nameserver-p &rest info)
  "Creates and signals (via error) one of two socket error 
conditions, based on the state of the arguments."
  (unless nameserver-p
    (setq errno (abs errno)))
  (if stream
    (error (make-condition 'socket-error
			   :stream stream
			   :code errno
			   :identifier (getf *socket-error-identifiers* errno :unknown)
			   :situation where
			   :format-control "~a (error #~d) during ~a"
			   :format-arguments (list
					      #+windows-target
					      (%windows-error-string errno)
					      #-windows-target
					      (%strerror errno)
					      errno where)))
    (let* ((identifiers (if nameserver-p
                          *gai-error-identifiers*
                          *socket-error-identifiers*))
           (connect-address (get-error-address-info info))
           (format-control (if nameserver-p
                             "~a (error #~d) during nameserver operation in ~a"
                             (if connect-address
                               "~a (error #~d) during attempt to connect to ~a"
                               "~a (error #~d) during socket creation operation in ~a")))
           (format-arguments (if connect-address
                               (list
                                #+windows-target
                                (%windows-error-string errno)
                                #-windows-target
                                (if nameserver-p
                                  (%gai-strerror errno)
                                  (%strerror errno))
                                errno
                                (if (atom connect-address)
                                    connect-address
                                    (destructuring-bind (address port) connect-address
                                      (if (numberp address)
                                          (format nil "~a:~d"
                                                  (ipaddr-to-dotted address)
                                                  port)
                                          (format nil "[~A]:~D"
                                                  address port)))))
                               (list
                                #+windows-target
                                (%windows-error-string errno)
                                #-windows-target
                                (if nameserver-p
                                  (%gai-strerror errno)
                                  (%strerror errno))
                                errno where))))
                              
      (error (make-condition 'socket-creation-error
			     :code errno
			     :identifier (getf identifiers errno :unknown)
			     :situation where
			     :format-control format-control
			     :format-arguments format-arguments
                             :remote-address connect-address)))))

;; If true, this will try to allow other cooperative processes to run
;; while socket io is happening.  Since CCL threads are preemptively
;; scheduled, this isn't particularly meaningful.
(defvar *multiprocessing-socket-io* nil)

(defclass socket ()
  ())

(defmacro with-open-socket ((var . args) &body body
			    &aux (socket (make-symbol "socket"))
			         (done (make-symbol "done")))
  "Execute body with var bound to the result of applying make-socket to
make-socket-args. The socket gets closed on exit."
  `(let (,socket ,done)
     (unwind-protect
	 (multiple-value-prog1
	   (let ((,var (setq ,socket (make-socket ,@args))))
	     ,@body)
	   (setq ,done t))
       (when ,socket (close ,socket :abort (not ,done))))))

(defgeneric socket-address-family (socket)
  (:documentation "Return :internet or :file, as appropriate."))

(defclass ip-socket (socket)
  ())

(defmethod socket-address-family ((socket ip-socket)) :internet)

(defclass file-socket (socket)
  ())

(defmethod socket-address-family ((socket file-socket)) :file)

(defclass tcp-socket (ip-socket)
  ())

(defgeneric socket-type (socket)
  (:documentation
   "Return :stream for tcp-stream and listener-socket, and :datagram
for udp-socket."))

(defmethod socket-type ((socket tcp-socket)) :stream)

(defclass stream-file-socket (file-socket)
  ())

(defmethod socket-type ((socket stream-file-socket)) :stream)


;;; An active TCP socket is an honest-to-goodness stream.
(defclass tcp-stream (tcp-socket)
  ())

(defclass fundamental-tcp-stream (tcp-stream
                                  fd-stream
                                  buffered-binary-io-stream-mixin
                                  buffered-character-io-stream-mixin)
    ())

(make-built-in-class 'basic-tcp-stream
                     'tcp-stream
                     'basic-binary-io-stream
                     'basic-character-io-stream)

(defgeneric socket-connect (stream)
 (:documentation
   "Return :active for tcp-stream, :passive for listener-socket, and NIL
for udp-socket"))

(defmethod socket-connect ((stream tcp-stream)) :active)

(defgeneric socket-format (stream)
  (:documentation
   "Return the socket format as specified by the :format argument to
make-socket."))

(defmethod socket-format ((stream tcp-stream))
  (if (eq (stream-element-type stream) 'character)
    :text
    ;; Should distinguish between :binary and :bivalent, but hardly
    ;; seems worth carrying around an extra slot just for that.
    :bivalent))

(defmethod socket-device ((stream tcp-stream))
  (let ((ioblock (stream-ioblock stream nil)))
    (and ioblock (ioblock-device ioblock))))

(defmethod select-stream-class ((class tcp-stream) in-p out-p char-p)
  (declare (ignore char-p)) ; TODO: is there any real reason to care about this?
  ;; Yes, in general.  There is.
  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
  'fundamental-tcp-stream)

(defmethod map-to-basic-stream-class-name ((name (eql 'tcp-stream)))
  'basic-tcp-stream)

(defmethod select-stream-class ((s (eql 'basic-tcp-stream)) in-p out-p char-p)
  (declare (ignore char-p))
  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
  'basic-tcp-stream)

;;; A FILE-SOCKET-STREAM is also honest. To goodness.
(defclass file-socket-stream (stream-file-socket)
  ())

(defclass fundamental-file-socket-stream (file-socket-stream
                                          fd-stream
                                          buffered-binary-io-stream-mixin
                                          buffered-character-io-stream-mixin)
    ())

(make-built-in-class 'basic-file-socket-stream
                     'file-socket-stream
                     'basic-binary-io-stream
                     'basic-character-io-stream)


(defmethod map-to-basic-stream-class-name ((name (eql 'file-socket-stream)))
  'basic-file-socket-stream)

(defmethod select-stream-class ((class file-socket-stream) in-p out-p char-p)
  (declare (ignore char-p)) ; TODO: is there any real reason to care about this?
  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
  'fundamental-file-socket-stream)

(defmethod select-stream-class ((s (eql 'basic-file-socket-stream)) in-p out-p char-p)
  (declare (ignore char-p))
  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
  'basic-file-socket-stream)

(defclass unconnected-socket (socket)
  ((device :initarg :device :accessor socket-device)
   (keys :initarg :keys :reader socket-keys)))

(defmethod socket-format ((socket unconnected-socket))
  (or (getf (socket-keys socket) :format) :text))

(defgeneric close (socket &key abort)
  (:documentation
   "The close generic function can be applied to sockets. It releases the
operating system resources associated with the socket."))

(defmethod close ((socket unconnected-socket) &key abort)
  (declare (ignore abort))
  (when (socket-device socket)
    (fd-close (socket-device socket))
    (setf (socket-device socket) nil)
    t))

;; A passive tcp socket just generates connection streams
(defclass listener-socket (tcp-socket unconnected-socket) ())

(defmethod SOCKET-CONNECT ((stream listener-socket)) :passive)

(defclass file-listener-socket (stream-file-socket unconnected-socket) ())

(defmethod SOCKET-CONNECT ((stream file-listener-socket)) :passive)

;;; A FILE-LISTENER-SOCKET should try to delete the filesystem
;;; entity when closing.

#-windows-target
(defmethod close :before ((s file-listener-socket) &key abort)
  (declare (ignore abort))
  (let* ((path (local-socket-filename (socket-device s) s)))
    (when path (%delete-file path))))


;; A udp socket just sends and receives packets.
(defclass udp-socket (ip-socket unconnected-socket) ())

(defmethod socket-type ((stream udp-socket)) :datagram)
(defmethod socket-connect ((stream udp-socket)) nil)
(defmethod socket-format ((stream udp-socket)) :binary)

(defgeneric socket-os-fd (socket)
  (:documentation
   "Return the native OS's representation of the socket, or NIL if the
socket is closed. On Unix, this is the Unix 'file descriptor', a small
non-negative integer. Note that it is rather dangerous to mess around
with tcp-stream fd's, as there is all sorts of buffering and asynchronous
I/O going on above the OS level. listener-socket and udp-socket fd's are
safer to mess with directly as there is less magic going on."))

;; Returns nil for closed stream...
(defmethod socket-os-fd ((socket socket))
  (socket-device socket))

;; Returns nil for closed stream
(defun local-socket-info (fd type socket)
  (and fd
       (rlet ((sockaddr :sockaddr_in)
	      (namelen :signed))
	     (setf (pref namelen :signed) (record-length :sockaddr_in))
	     (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen))
	     (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
	       (ecase type
		 (:host (ntohl (pref sockaddr
                                     #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                                     #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)))
		 (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))

#-windows-target
(defun path-from-unix-address (addr)
  (when (= #$AF_UNIX (pref addr :sockaddr_un.sun_family))
    #+darwin-target
    (%str-from-ptr (pref addr :sockaddr_un.sun_path)
		   (- (pref addr :sockaddr_un.sun_len) 2))
    #-darwin-target
    (%get-cstring (pref addr :sockaddr_un.sun_path))))

#-windows-target
(defun local-socket-filename (fd socket)
  (and fd
       (rlet ((addr :sockaddr_un)
              (namelen :signed))
         (setf (pref namelen :signed) (record-length :sockaddr_un))
         (socket-call socket "getsockname" (c_getsockname fd addr namelen))
	 (path-from-unix-address addr))))

(defmacro with-if ((var expr) &body body)
  `(let ((,var ,expr))
     (if ,var
	 (progn
	   ,@body))))     

(defun remote-socket-info (socket type)
  (with-if (fd (socket-device socket))
    (rlet ((sockaddr :sockaddr_in)
	   (namelen :signed))
	  (setf (pref namelen :signed) (record-length :sockaddr_in))
	  (let ((err (c_getpeername fd sockaddr namelen)))
	    (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil)
		  ((< err 0) (socket-error socket "getpeername" err nil))
		  (t
		   (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
		     (ecase type
		       (:host (ntohl (pref sockaddr
                                           #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                                           #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr)))
		       (:port (ntohs  (pref sockaddr :sockaddr_in.sin_port)))))))))))

#-windows-target
(defun remote-socket-filename (socket)
  (with-if (fd (socket-device socket))
    (rlet ((addr :sockaddr_un)
	   (namelen :signed))
	  (setf (pref namelen :signed) (record-length :sockaddr_un))
	  (let* ((err (c_getsockname fd addr namelen)))
	    (cond ((eql err (- #$ENOTCONN)) nil)
		  ((< err 0) (socket-error socket "getpeername" err nil))
		  (t (path-from-unix-address addr)))))))

(defgeneric local-port (socket)
  (:documentation "Return the local port number."))

(defmethod local-port ((socket socket))
  (local-socket-info (socket-device socket) :port socket))

(defgeneric local-host (socket)
  (:documentation
   "Return 32-bit unsigned IP address of the local host."))

(defmethod local-host ((socket socket))
  (local-socket-info (socket-device socket) :host socket))

#-windows-target
(defmethod local-filename ((socket socket))
  (local-socket-filename (socket-device socket) socket))

(defgeneric remote-host (socket)
  (:documentation
   "Return the 32-bit unsigned IP address of the remote host, or NIL if
the socket is not connected."))

;; Returns NIL if socket is not connected
(defmethod remote-host ((socket socket))
  (remote-socket-info socket :host))

(defgeneric remote-port (socket)
  (:documentation
   "Return the remote port number, or NIL if the socket is not connected."))

(defmethod remote-port ((socket socket))
  (remote-socket-info socket :port))

#-windows-target
(defmethod remote-filename ((socket socket))
  (remote-socket-filename socket))
  
(defun set-socket-fd-blocking (fd block-flag)
  #+windows-target
  (rlet ((argp :u_long (if block-flag 0 1)))
    (#_ioctlsocket fd #$FIONBIO argp))
  #-windows-target
  (if block-flag
    (fd-clear-flag fd #$O_NONBLOCK)
    (fd-set-flag fd #$O_NONBLOCK)))

(defun get-socket-fd-blocking (fd)
  "returns T iff socket is in blocking mode"
  #+windows-target (declare (ignore fd))
  #+windows-target t
  #-windows-target
  (not (logtest #$O_NONBLOCK (fd-get-flags fd))))

(defmethod socket-bind-local (socket fd (address-family (eql :internet)) local-host local-port proto)
  (let* ((port-n (if local-port (port-as-inet-port local-port proto) 0))
         (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY)))
    (rletz ((sockaddr :sockaddr_in))
      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
            (pref sockaddr :sockaddr_in.sin_port) port-n
            (pref sockaddr
                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                  #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)
            host-n)
      (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in))))))

(defmethod socket-bind-local (socket fd (address-family (eql :internet6)) local-host local-port proto)
  (rletz ((sockaddr :sockaddr_in6))
    (setf (pref sockaddr :sockaddr_in6.sin6_family) #$AF_INET6
          (pref sockaddr :sockaddr_in6.sin6_port) (if local-port (port-as-inet-port local-port proto) 0))
    (if local-host
        (loop with host-n = (host-as-inet6-host local-host)
              for i below 16
              do (setf (paref (pref sockaddr :sockaddr_in6.sin6_addr) :uint8_t i) (aref host-n i)))
        (loop for i below 16
              do (setf (paref (pref sockaddr :sockaddr_in6.sin6_addr) :uint8_t i) (paref #$in6addr_any :uint8_t i))))
    (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in6)))))

(defun set-socket-options (fd-or-socket &key 
			   keepalive
			   reuse-address
			   nodelay
			   broadcast
			   linger
			   address-family
			   local-port
			   local-host
			   local-filename
			   type
			   connect
			   out-of-band-inline
			   &allow-other-keys)
  ;; see man socket(7) tcp(7) ip(7)
  (multiple-value-bind (socket fd) (etypecase fd-or-socket
				     (socket (values fd-or-socket (socket-device fd-or-socket)))
				     (integer (values nil fd-or-socket)))
    
    (if (null address-family)
	(setq address-family :internet))
    (when keepalive
      (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1))
    (when reuse-address
      (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1))
    (when broadcast
      (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1))
    (when out-of-band-inline
      (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1))
    (when (member address-family '(:internet :internet6))
      (when (eq type :stream)
	(rlet ((plinger :linger))
	  (setf (pref plinger :linger.l_onoff) (if linger 1 0)
		(pref plinger :linger.l_linger) (or linger 0))
	  (socket-call socket "setsockopt"
		       (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER
				     plinger (record-length :linger)))))
      (when nodelay
	(int-setsockopt fd
			#+linux-target #$SOL_TCP
			#-linux-target #$IPPROTO_TCP
			#$TCP_NODELAY 1))
      (when (or local-port local-host)
        (socket-bind-local socket fd address-family local-host local-port (if (eq type :stream) "tcp" "udp"))))
    (when (and (eq address-family :file)
	       (eq connect :passive)
	       local-filename)
      #+windows-target (error "can't create file socket on Windows")
      #-windows-target (bind-unix-socket fd local-filename))))

;; I hope the inline declaration makes the &rest/apply's go away...
(declaim (inline make-ip-socket))
(defun make-ip-socket (&rest keys &key type &allow-other-keys)
  (declare (dynamic-extent keys))
  (ecase type
    ((nil :stream) (apply #'make-tcp-socket keys))
    ((:datagram) (apply #'make-udp-socket keys))))

(declaim (inline make-file-socket))
(defun make-file-socket (&rest keys &key type &allow-other-keys)
  (declare (dynamic-extent keys))
  (ecase type
    ((nil :stream) (apply #'make-stream-file-socket keys))
    (:datagram (apply #'make-datagram-file-socket keys))))

(defun make-socket (&rest keys
		    &key address-family
		    ;; List all keys here just for error checking...
		    ;; &allow-other-keys
		    type connect remote-host remote-port eol format
		    keepalive reuse-address nodelay broadcast linger
		    local-port local-host backlog class out-of-band-inline
		    local-filename remote-filename sharing basic
                    external-format (auto-close t)
                    connect-timeout input-timeout output-timeout deadline
                    fd)
  "Create and return a new socket."
  (declare (dynamic-extent keys))
  (declare (ignore type connect remote-host remote-port eol format
		   keepalive reuse-address nodelay broadcast linger
		   local-port local-host backlog class out-of-band-inline
		   local-filename remote-filename sharing basic external-format
                   auto-close connect-timeout input-timeout output-timeout deadline fd))
  (ecase address-family
    ((:file) (apply #'make-file-socket keys))
    ((nil :internet :internet6) (apply #'make-ip-socket keys))))



(defun make-udp-socket (&rest keys &key (fd -1) address-family &allow-other-keys)
  (unwind-protect
    (let (socket)
      (when (< fd 0)
        (setq fd (socket-call nil "socket"
                              (c_socket (ecase address-family
                                          (:internet #$AF_INET)
                                          (:internet6 #$AF_INET6))
                                        #$SOCK_DGRAM #$IPPROTO_UDP))))
      (apply #'set-socket-options fd keys)
      (setq socket (make-instance 'udp-socket
				  :device fd
				  :keys keys))
      (setq fd -1)
      socket)
    (unless (< fd 0)
      (fd-close fd))))

(defun make-tcp-socket (&rest keys &key connect (fd -1) address-family &allow-other-keys)
  (unwind-protect
       (let (socket)
         (when (< fd 0)
           (setq fd (socket-call nil "socket"
                                 (c_socket (ecase address-family
                                             (:internet #$AF_INET)
                                             (:internet6 #$AF_INET6))
                                           #$SOCK_STREAM #$IPPROTO_TCP))))
         (apply #'set-socket-options fd keys)
         (setq socket
               (ecase connect
                 ((nil :active) (apply #'make-tcp-stream-socket fd keys))
                 ((:passive) (apply #'make-tcp-listener-socket fd keys))))
         (setq fd -1)
         socket)
    (unless (< fd 0)
      (fd-close fd))))

(defun make-stream-file-socket (&rest keys &key connect (fd -1) &allow-other-keys)
  (unwind-protect
       (let (socket)
         (when (< fd 0)
           (setq fd (socket-call nil "socket" (c_socket #$PF_UNIX #$SOCK_STREAM 0))))
         (apply #'set-socket-options fd keys)
         (setq socket
               (ecase connect
                 ((nil :active) (apply #'make-file-stream-socket fd keys))
                 ((:passive) (apply #'make-file-listener-socket fd keys))))
         (setq fd -1)
         socket)
    (unless (< fd 0)
      (fd-close fd))))

(defun make-datagram-file-socket (&rest keys)
  (declare (ignore keys))
  (error "Datagram file sockets aren't implemented."))


(defun %socket-connect (fd addr addrlen &optional timeout-in-milliseconds)
  (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds)))
    (declare (fixnum err))
    (unless (eql err 0) #||(fd-close fd)||# (socket-error nil "connect" err nil :sockaddr addr))))
    
(defun inet-connect (fd host-n port-n timeout-in-milliseconds)
  (rlet ((sockaddr :sockaddr_in))
    (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
          (pref sockaddr :sockaddr_in.sin_port) port-n
          (pref sockaddr
                #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr
                ) host-n)
    (%socket-connect fd sockaddr (record-length :sockaddr_in) timeout-in-milliseconds)))

(defun inet6-connect (fd host-n port-n timeout-in-milliseconds)
  (rletz ((sockaddr :sockaddr_in6))
    (setf (pref sockaddr :sockaddr_in6.sin6_family) #$AF_INET6
          (pref sockaddr :sockaddr_in6.sin6_port) port-n)
    (loop for i below 16
          do (setf (paref (pref sockaddr :sockaddr_in6.sin6_addr) :uint8_t i) (aref host-n i)))
    (%socket-connect fd sockaddr (record-length :sockaddr_in6) timeout-in-milliseconds)))

#-windows-target
(defun file-socket-connect (fd remote-filename)
  (rletz ((sockaddr :sockaddr_un))
    (init-unix-sockaddr sockaddr remote-filename)
    (%socket-connect fd sockaddr (record-length :sockaddr_un))))

#+windows-target
(defun file-socket-connect (fd remote-filename)
  (declare (ignore fd))
  (error "Can't create file socket to ~s on Windows" remote-filename))
  
(defun make-tcp-stream-socket (fd &rest keys
                                  &key remote-host
				  remote-port
                                  connect-timeout
                                  deadline
                                  address-family
				  &allow-other-keys)
  (let* ((timeout-in-milliseconds
          (if deadline
            (max (round (- deadline (get-internal-real-time))
                        (/ internal-time-units-per-second 1000))
                 0)
            (if connect-timeout
              (round (* connect-timeout 1000))))))
    (ecase address-family
      (:internet (inet-connect fd
                               (host-as-inet-host remote-host)
                               (port-as-inet-port remote-port "tcp")
                               timeout-in-milliseconds))
      (:internet6 (inet6-connect fd
                                 (host-as-inet6-host remote-host)
                                 (port-as-inet-port remote-port "tcp")
                                 timeout-in-milliseconds)))
    (apply #'make-tcp-stream fd keys)))

(defun make-file-stream-socket (fd &rest keys
                                   &key remote-filename
                                   &allow-other-keys)
  (file-socket-connect fd remote-filename)
  (apply #'make-file-socket-stream fd keys))


(defun make-tcp-stream (fd
                        &key (format :bivalent)
                             external-format
                             (class 'tcp-stream)
                             sharing
                             (basic t)
                             (auto-close t)
                             input-timeout
                             output-timeout
                             deadline
                        &allow-other-keys)
  (let* ((external-format (normalize-external-format :socket external-format)))
    (let ((element-type (ecase format
                          ((nil :text) 'character)
                          ((:binary :bivalent) '(unsigned-byte 8)))))
      ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close
      ;; See if should specialize any of 'em.
      (make-fd-stream fd
                      :class class
                      :direction :io
                      :element-type element-type
                      :sharing sharing
                      :character-p (not (eq format :binary))
                      :encoding (external-format-character-encoding external-format)
                      :line-termination (external-format-line-termination external-format)
                      :basic basic
                      :auto-close auto-close
                      :input-timeout input-timeout
                      :output-timeout output-timeout
                      :deadline deadline))))

(defun make-file-socket-stream (fd
                                &key (format :bivalent)
                                external-format
                                (class 'file-socket-stream)
                                sharing
                                basic
                                (auto-close t)
                                input-timeout
                                output-timeout
                                deadline
                                &allow-other-keys)
  (let* ((external-format (normalize-external-format :socket external-format)))
  
    (let ((element-type (ecase format
                          ((nil :text) 'character)
                          ((:binary :bivalent) '(unsigned-byte 8)))))
      ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close
      ;; See if should specialize any of 'em.
      (make-fd-stream fd
                      :class class
                      :direction :io
                      :element-type element-type
                      :encoding (external-format-character-encoding external-format)
                      :line-termination (external-format-line-termination external-format)
                      :sharing sharing
                      :character-p (not (eq format :binary))
                      :basic basic
                      :auto-close auto-close
                      :input-timeout input-timeout
                      :output-timeout output-timeout
                      :deadline deadline))))

(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
  (socket-call nil "listen" (c_listen fd (or backlog 5)))
  (make-instance 'listener-socket
		 :device fd
		 :keys keys))

(defun make-file-listener-socket (fd &rest keys &key backlog &allow-other-keys)
  (socket-call nil "listen" (c_listen fd (or backlog 5)))
  (make-instance 'file-listener-socket
		 :device fd
		 :keys keys))

(defun socket-accept (fd wait)
  (flet ((_accept (fd async)
	   (let ((res (c_accept fd (%null-ptr) (%null-ptr))))
	     (declare (fixnum res))
	     ;; See the inscrutable note under ERROR HANDLING in
	     ;; man accept(2). This is my best guess at what they mean...
	     (if (and async (< res 0)
                      #+windows-target
                      (= res (- #$WSAEWOULDBLOCK))
                      #-windows-target
		      (or (eql res (- #$ENETDOWN))
			  (eql res (- #+linux-target #$EPROTO
				      #-linux-target  #$EPROTOTYPE))
			  (eql res (- #$ENOPROTOOPT))
			  (eql res (- #$EHOSTDOWN))
			  (eql res (- #+linux-target #$ENONET
				      #-linux-target #$ENETDOWN))
			  (eql res (- #$EHOSTUNREACH))
			  (eql res (- #$EOPNOTSUPP))
			  (eql res (- #$ENETUNREACH))))
	       (- #$EAGAIN)
               res))))
    (cond (wait
	    (with-eagain fd :input
	      (_accept fd *multiprocessing-socket-io*)))
	  (*multiprocessing-socket-io*
	    (_accept fd t))
	  (t
	    (let ((was-blocking (get-socket-fd-blocking fd)))
	      (unwind-protect
		  (progn
                    (set-socket-fd-blocking fd nil)
		    (_accept fd t))
		(set-socket-fd-blocking fd was-blocking)))))))

(defun accept-socket-connection (socket wait stream-create-function &optional stream-args)
  (let ((listen-fd (socket-device socket))
	(fd -1))
    (unwind-protect
      (let ((keys (append stream-args (socket-keys socket))))
	(setq fd (socket-accept listen-fd wait))
	(cond ((>= fd 0)
	       (prog1 (apply stream-create-function fd keys)
		 (setq fd -1)))
	      ((eql fd (- #$EAGAIN)) nil)
	      (t (socket-error socket "accept" fd nil))))
      (when (>= fd 0)
	(fd-close fd)))))

(defgeneric accept-connection (socket &key wait stream-args)
  (:documentation
  "Extract the first connection on the queue of pending connections,
accept it (i.e. complete the connection startup protocol) and return a new
tcp-stream or file-socket-stream representing the newly established
connection.  The tcp stream inherits any properties of the listener socket
that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments
may be specified using STREAM-ARGS. The original listener
socket continues to be open listening for more connections, so you can call
accept-connection on it again."))

(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args)
  (accept-socket-connection socket wait #'make-tcp-stream stream-args))

(defmethod accept-connection ((socket file-listener-socket) &key (wait t) stream-args)
  (accept-socket-connection socket wait #'make-file-socket-stream stream-args))

(defun verify-socket-buffer (buf offset size)
  (unless offset (setq offset 0))
  (unless (<= (+ offset size) (length buf))
    (report-bad-arg size `(integer 0 ,(- (length buf) offset))))
  (multiple-value-bind (arr start) (array-data-and-offset buf)
    (setq buf arr offset (+ offset start)))
  ;; TODO: maybe should allow any raw vector
  (let ((subtype (typecode buf)))
    (unless #+ppc32-target (and (<= ppc32::min-8-bit-ivector-subtag subtype)
                                (<= subtype ppc32::max-8-bit-ivector-subtag))
            #+ppc64-target (= (the fixnum (logand subtype ppc64::fulltagmask))
                              ppc64::ivector-class-8-bit)
            #+x8632-target (and (<= x8632::min-8-bit-ivector-subtag subtype)
                                (<= subtype x8632::max-8-bit-ivector-subtag))
            #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
                                (<= subtype x8664::max-8-bit-ivector-subtag))
            #+arm-target (and (<= arm::min-8-bit-ivector-subtag subtype)
                                (<= subtype arm::max-8-bit-ivector-subtag))
      (report-bad-arg buf `(or (array (unsigned-byte 8))
			       (array (signed-byte 8))))))
  (values buf offset))

(defmethod send-to ((socket udp-socket) msg size
		    &key remote-host remote-port offset)
  "Send a UDP packet over a socket."
  (let ((fd (socket-device socket)))
    (multiple-value-setq (msg offset) (verify-socket-buffer msg offset size))
    (unless remote-host
      (setq remote-host (or (getf (socket-keys socket) :remote-host)
			    (remote-socket-info socket :host))))
    (unless remote-port
      (setq remote-port (or (getf (socket-keys socket) :remote-port)
			    (remote-socket-info socket :port))))
    (rlet ((sockaddr :sockaddr_in))
      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
      (setf (pref sockaddr
                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                  #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr)
	    (if remote-host (host-as-inet-host remote-host) #$INADDR_ANY))
      (setf (pref sockaddr :sockaddr_in.sin_port)
	    (if remote-port (port-as-inet-port remote-port "udp") 0))
      (%stack-block ((bufptr size))
        (%copy-ivector-to-ptr msg offset bufptr 0 size)
	(socket-call socket "sendto"
	  (with-eagain fd :output
	    (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in))))))))

(defmethod receive-from ((socket udp-socket) size &key buffer extract offset)
  "Read a UDP packet from a socket. If no packets are available, wait for
a packet to arrive. Returns four values:
  The buffer with the data
  The number of bytes read
  The 32-bit unsigned IP address of the sender of the data
  The port number of the sender of the data."
  (let ((fd (socket-device socket))
	(vec-offset offset)
	(vec buffer)
	(ret-size -1))
    (when vec
      (multiple-value-setq (vec vec-offset)
	(verify-socket-buffer vec vec-offset size)))
    (rlet ((sockaddr :sockaddr_in)
	   (namelen :signed))
      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
      (setf (pref sockaddr
                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                  #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)
            #$INADDR_ANY)
      (setf (pref sockaddr :sockaddr_in.sin_port) 0)
      (setf (pref namelen :signed) (record-length :sockaddr_in))
      (%stack-block ((bufptr size))
	(setq ret-size (socket-call socket "recvfrom"
			 (with-eagain fd :input
			   (c_recvfrom fd bufptr size 0 sockaddr namelen))))
	(unless vec
	  (setq vec (make-array ret-size
				:element-type
				(ecase (socket-format socket)
				  ((:binary) '(unsigned-byte 8))))
		vec-offset 0))
	(%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size))
      (values (cond ((null buffer)
		     vec)
		    ((or (not extract)
			 (and (eql 0 (or offset 0))
			      (eql ret-size (length buffer))))
		     buffer)
		    (t 
		     (subseq vec vec-offset (+ vec-offset ret-size))))
	      ret-size
	      (ntohl (pref sockaddr
                           #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
                           #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))
	      (ntohs (pref sockaddr :sockaddr_in.sin_port))))))

(defgeneric shutdown (socket &key direction)
  (:documentation
   "Shut down part of a bidirectional connection. This is useful if e.g.
you need to read responses after sending an end-of-file signal."))

(defmethod shutdown (socket &key direction)
  ;; TODO: should we ignore ENOTCONN error?  (at least make sure it
  ;; is a distinct, catchable error type).
  (let ((fd (socket-device socket)))
    (socket-call socket "shutdown"
      (c_shutdown fd (ecase direction
		       (:input 0)
		       (:output 1))))))

;; Accepts port as specified by user, returns port number in network byte
;; order.  Protocol should be one of "tcp" or "udp".  Error if not known.
(defun port-as-inet-port (port proto)
  (or (etypecase port
	(fixnum (htons port))
	(string (_getservbyname port proto))
	(symbol (_getservbyname (string-downcase (symbol-name port)) proto)))
      (socket-error nil "getservbyname" (- #$ENOENT) nil)))

(defun lookup-port (port proto)
  "Find the port number for the specified port and protocol."
  (if (fixnump port)
    port
    (ntohs (port-as-inet-port port proto))))

;; Accepts host as specified by user, returns host number in network byte
;; order.
(defun host-as-inet-host (host)
  (etypecase host
    (integer (htonl host))
    (string (or (and (every #'(lambda (c) (position c ".0123456789")) host)
		     (_inet_aton host))
		(multiple-value-bind (addr err) (c_gethostbyname host #$AF_INET)
		  (or addr
		      (socket-error nil "gethostbyname" err t)))))))

(defun host-as-inet6-host (host)
  (etypecase host
    ((array () (16)) host)
    (string (or (_inet_pton #$AF_INET6 host)
		(multiple-value-bind (addr err) (c_gethostbyname host #$AF_INET6)
		  (or addr
		      (socket-error nil "gethostbyname" err t)))))))

(defun _inet_pton (address-family string)
  (with-cstr (addr-string string)
    (rlet ((addr :in6_addr))
      (unless (zerop (#_inet_pton address-family addr-string addr))
        (ecase address-family
          (#.#$AF_INET (pref addr #-solaris-target :in_addr.s_addr
                                  #+solaris-target #>in_addr.S_un.S_addr))
          (#.#$AF_INET6 (loop with result = (make-array 16 :element-type '(unsigned-byte 8))
                              for i below 16
                              do (setf (aref result i) (paref (pref addr :in6_addr) :uint8_t i))
                              finally (return result))))))))

(defun _inet_ntop (address-family address)
  (%stack-block ((string-buffer 100))
    (multiple-value-bind (result errno) (#_inet_ntop address-family address string-buffer 100)
    (if (%null-ptr-p result)
        (error "could not convert address to string, error ~S" errno)
        (%get-cstring string-buffer)))))

(defun dotted-to-ipaddr (name &key (errorp t))
  "Convert a dotted-string representation of a host address to a 32-bit
unsigned IP address."
  (let ((addr (_inet_aton name)))
    (if addr (ntohl addr)
      (and errorp (error "Invalid dotted address ~s" name)))))
    
(defun lookup-hostname (host)
  "Convert a host spec in any of the acceptable formats into a 32-bit
unsigned IP address."
  (if (typep host 'integer)
    host
    (ntohl (host-as-inet-host host))))

(defun ipaddr-to-dotted (addr &key values)
  "Convert a 32-bit unsigned IP address into octets."
  (let* ((a (ldb (byte 8 24) addr))
	 (b (ldb (byte 8 16) addr))
	 (c (ldb (byte 8  8) addr))
	 (d (ldb (byte 8  0) addr)))
    (if values
      (values a b c d)
      (format nil "~d.~d.~d.~d" a b c d))))

(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
  "Convert a 32-bit unsigned IP address into a host name string."
  (declare (ignore ignore-cache))
  (multiple-value-bind (name err) (c_gethostbyaddr (htonl ipaddr))
    (or name (socket-error nil "gethostbyaddr" err t))))
  

(defun int-getsockopt (socket level optname)
  (rlet ((valptr :signed)
         (vallen :signed))
    (setf (pref vallen :signed) 4)
    (let* ((err (c_getsockopt socket level optname valptr vallen)))
      (if (and (eql 0 err)
               (eql 4 (pref vallen :signed)))
        (pref valptr :signed)
	(socket-error socket "getsockopt" err nil)))))

(defun timeval-setsockopt (socket level optname timeout)
    (multiple-value-bind (seconds micros)
        (microseconds timeout)
      (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros))
        (socket-call socket "setsockopt"
          (c_setsockopt socket level optname valptr (record-length :timeval))))))
                   
(defun int-setsockopt (socket level optname optval)
  (rlet ((valptr :signed))
    (setf (pref valptr :signed) optval)
    (socket-call socket "setsockopt"
      (c_setsockopt socket level optname valptr (record-length :signed)))))



            
(defun c_gethostbyaddr (addr-in-net-byte-order)
  (rletZ ((sin #>sockaddr_in))
    (setf (pref sin :sockaddr_in.sin_family) #$AF_INET
          (pref sin
                #+(or windows-target solaris-target) #>sockaddr_in.sin_addr.S_un.S_addr
                #-(or windows-target solaris-target) #>sockaddr_in.sin_addr.s_addr) addr-in-net-byte-order)
    #+darwin-target (setf (pref sin :sockaddr_in.sin_len) (record-length :sockaddr_in))
    (%stack-block ((namep #$NI_MAXHOST))
      (let* ((err (#_getnameinfo sin (record-length #>sockaddr_in) namep #$NI_MAXHOST (%null-ptr) 0 #$NI_NAMEREQD)))
        (if (eql 0 err)
          (%get-cstring namep)
          (values nil err))))))
                
(defun c_gethostbyname (name address-family)
  (with-cstrs ((name (string name)))
    (rletZ ((hints #>addrinfo)
            (results :address))
      (setf (pref hints #>addrinfo.ai_family) address-family)
      (let* ((err (#_getaddrinfo name (%null-ptr) hints results)))
        (if (eql 0 err)
          (let* ((info (pref results :address))
                 (sin (pref info #>addrinfo.ai_addr)))
            (prog1
                (ecase address-family
                  (#.#$AF_INET
                   #+(or windows-target solaris-target)
                   (pref sin #>sockaddr_in.sin_addr.S_un.S_addr)
                   #-(or windows-target solaris-target)
                   (pref sin #>sockaddr_in.sin_addr.s_addr))
                  (#.#$AF_INET6
                   (loop with result = (make-array 16 :element-type '(unsigned-byte 8))
                         for i below 16
                         do (setf (aref result i) (paref (pref sin :sockaddr_in6.sin6_addr) :uint8_t i))
                         finally (return result))))
              (#_freeaddrinfo info)))
          (values nil err))))))
      
  

  

(defun _getservbyname (name proto)
  (with-cstrs ((name (string name))
	       (proto (string proto)))
    (let* ((servent-ptr (%null-ptr)))
      (declare (dynamic-extent servent-ptr))
      (%setf-macptr servent-ptr (#_getservbyname name proto))
      (unless (%null-ptr-p servent-ptr)
	(pref servent-ptr :servent.s_port)))))

(defun _inet_aton (string)
  (with-cstrs ((name string))
    #-windows-target
    (rlet ((addr :in_addr))
      (let* ((result #+freebsd-target (#___inet_aton name addr)
                     #-freebsd-target (#_inet_aton name addr)))
	(unless (eql result 0)
	  (pref addr
                #-solaris-target :in_addr.s_addr
                #+solaris-target #>in_addr.S_un.S_addr
                ))))
    #+windows-target
    (rlet ((addr :sockaddr_in)
           (addrlenp :int (record-length :sockaddr_in)))
      (setf (pref addr :sockaddr_in.sin_family) #$AF_INET)
      (when (zerop (#_WSAStringToAddressA name #$AF_INET (%null-ptr)  addr addrlenp))
        (pref addr #>sockaddr_in.sin_addr.S_un.S_addr)))))

(defun c_socket_1 (domain type protocol)
  #-windows-target (int-errno-call (#_socket domain type protocol))
  #+windows-target (let* ((handle (#_socket domain type protocol)))
                     (if (< handle 0)
                       (%get-winsock-error)
                       handle)))



(defun c_socket (domain type protocol)
  (let* ((fd (c_socket_1 domain type protocol)))
    (when (or (eql fd (- #$EMFILE))
              (eql fd (- #$ENFILE)))
      (gc)
      (drain-termination-queue)
      (setq fd (c_socket_1 domain type protocol)))
    fd))
      

#-windows-target
(defun init-unix-sockaddr (addr path)
  (macrolet ((sockaddr_un-path-len ()
               (/ (ensure-foreign-type-bits
                   (foreign-record-field-type 
                    (%find-foreign-record-type-field
                     (parse-foreign-type '(:struct :sockaddr_un)) :sun_path)))
                  8)))
    (let* ((name (defaulted-native-namestring path))
           (namelen (length name))
           (pathlen (sockaddr_un-path-len))
           (copylen (min (1- pathlen) namelen)))
      (setf (pref addr :sockaddr_un.sun_family) #$AF_UNIX)
      (let* ((sun-path (pref addr :sockaddr_un.sun_path)))
        (dotimes (i copylen)
          (setf (%get-unsigned-byte sun-path i)
                (let* ((code (char-code (schar name i))))
                  (if (> code 255)
                    (char-code #\Sub)
                    code))))))))

#-windows-target
(defun bind-unix-socket (socketfd path)
  (rletz ((addr :sockaddr_un))
    (init-unix-sockaddr addr path)
    (socket-call
     nil
     "bind"
     (c_bind socketfd
             addr
             (+ 2
                (#_strlen
                 (pref addr :sockaddr_un.sun_path)))))))
      

(defun c_bind (sockfd sockaddr addrlen)
  (check-socket-error (#_bind sockfd sockaddr addrlen)))


#+windows-target
(defun windows-connect-wait (sockfd timeout-in-milliseconds)
  (if (and timeout-in-milliseconds
           (< timeout-in-milliseconds 0))
    (setq timeout-in-milliseconds nil))
  (rlet ((writefds :fd_set)
         (exceptfds :fd_set)
         (tv :timeval :tv_sec 0 :tv_usec 0))
    (fd-zero writefds)
    (fd-zero exceptfds)
    (fd-set sockfd writefds)
    (fd-set sockfd exceptfds)
    (when timeout-in-milliseconds
      (multiple-value-bind (seconds milliseconds)
          (floor timeout-in-milliseconds 1000)
        (setf (pref tv :timeval.tv_sec) seconds
              (pref tv :timeval.tv_usec) (* 1000 milliseconds))))
    (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseconds tv (%null-ptr))) 0)))
      
      
;;; If attempts to connect are interrupted, we basically have to
;;; wait in #_select (or the equivalent).  There's a good rant
;;; about these issues in:
;;; <http://www.madore.org/~david/computers/connect-intr.html>
(defun c_connect (sockfd addr len &optional timeout-in-milliseconds)
  (let* ((was-blocking (get-socket-fd-blocking sockfd)))
    (unwind-protect
         (progn
           (set-socket-fd-blocking sockfd nil)
           (let* ((err (check-socket-error (#_connect sockfd addr len))))
             (cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS
                                    
                                    #-windows-target #$EINPROGRESS))
                        #+windows-target (eql err (- #$WSAEWOULDBLOCK))
                        (eql err (- #$EINTR)))
                    (if
                      #+windows-target (windows-connect-wait sockfd timeout-in-milliseconds)
                      #-windows-target (process-output-wait sockfd timeout-in-milliseconds)
                      (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
                      (- #+windows-target #$WSAETIMEDOUT #-windows-target #$ETIMEDOUT)))
                   (t err))))
      (set-socket-fd-blocking sockfd was-blocking))))

(defun c_listen (sockfd backlog)
  (check-socket-error (#_listen sockfd backlog)))

(defun c_accept (sockfd addrp addrlenp)
  (ignoring-eintr
   (check-socket-error (#_accept sockfd addrp addrlenp))))

(defun c_getsockname (sockfd addrp addrlenp)
  (check-socket-error (#_getsockname sockfd addrp addrlenp)))

(defun c_getpeername (sockfd addrp addrlenp)
  (check-socket-error (#_getpeername sockfd addrp addrlenp)))

#-windows-target
(defun c_socketpair (domain type protocol socketsptr)
  (check-socket-error (#_socketpair domain type protocol socketsptr)))


(defun c_sendto (sockfd msgptr len flags addrp addrlen)
  (ignoring-eintr (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen))))

(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp)
  (ignoring-eintr (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp))))

(defun c_shutdown (sockfd how)
  (check-socket-error (#_shutdown sockfd how)))

(defun c_setsockopt (sockfd level optname optvalp optlen)
  (check-socket-error (#_setsockopt sockfd level optname optvalp optlen)))

(defun c_getsockopt (sockfd level optname optvalp optlenp)
  (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp)))

#-windows-target
(defun c_sendmsg (sockfd msghdrp flags)
  (check-socket-error (#_sendmsg sockfd msghdrp flags)))

#-windows-target
(defun c_recvmsg (sockfd msghdrp flags)
  (check-socket-error   (#_recvmsg sockfd msghdrp flags)))

;;; Return a list of currently configured interfaces, a la ifconfig.
(defstruct ip-interface
  name
  addr
  netmask
  flags
  address-family)

(defun dump-buffer (p n)
  (dotimes (i n (progn (terpri) (terpri)))
    (unless (logtest i 15)
      (format t "~&~8,'0x: " (%ptr-to-int (%inc-ptr p i))))
    (format t " ~2,'0x" (%get-byte p i))))

#-(or windows-target solaris-target)
(defun %get-ip-interfaces ()
  #-android-target
  (rlet ((p :address (%null-ptr)))
    (if (zerop (#_getifaddrs p))
      (unwind-protect
           (do* ((q (%get-ptr p) (pref q :ifaddrs.ifa_next))
                 (res ()))
                ((%null-ptr-p q) (nreverse res))
             (let* ((addr (pref q :ifaddrs.ifa_addr)))
               (when (and (not (%null-ptr-p addr))
                          (eql (pref addr :sockaddr.sa_family) #$AF_INET))
                 (push (make-ip-interface
                        :name (%get-cstring (pref q :ifaddrs.ifa_name))
                        :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr))
                        :netmask (ntohl
                                  (pref (pref q :ifaddrs.ifa_netmask)
                                       :sockaddr_in.sin_addr.s_addr))
                        :flags (pref q :ifaddrs.ifa_flags)
                        :address-family #$AF_INET)
                       res))))
        (#_freeifaddrs (pref p :address))))))

#+solaris-target
(progn
  ;;; Interface translator has trouble with a lot of ioctl constants.
  (eval-when (:compile-toplevel :execute)
    (defconstant os::|SIOCGLIFNUM| #xc00c6982)
    (defconstant os::|SIOCGLIFCONF| #xc01069a5)
    (defconstant os::|SIOCGLIFADDR| #xc0786971)
    (defconstant os::|SIOCGLIFFLAGS| #xc0786975)
    (defconstant os::|SIOCGLIFNETMASK| #xc078697d)
    )

(defun %get-ip-interfaces ()
  (let* ((sock (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))
         (res nil))
    (when (>= sock 0)
      (unwind-protect
           (let* ((flags (logior #$LIFC_NOXMIT #$LIFC_TEMPORARY #$LIFC_ALLZONES))
                  (ninterfaces (rlet ((lifnum :lifnum
                                        :lifn_flags flags
                                        :lifn_family #$AF_INET
                                        :lifn_count 0))
                                 (#_ioctl sock os::SIOCGLIFNUM :address lifnum)
                                 (pref lifnum :lifnum.lifn_count))))
             (declare (fixnum ninterfaces))
             (when (> ninterfaces 0)
               (let* ((bufsize (* ninterfaces (record-length :lifreq))))
                 (%stack-block ((buf bufsize :clear t))
                   (rlet ((lifc :lifconf
                            :lifc_family #$AF_INET
                            :lifc_flags flags
                            :lifc_len bufsize
                            :lifc_lifcu.lifcu_buf buf))
                     (when (>= (#_ioctl sock os::SIOCGLIFCONF :address lifc) 0)
                       (do* ((i 0 (1+ i))
                             (p (pref lifc :lifconf.lifc_lifcu.lifcu_buf)
                                (%inc-ptr p (record-length :lifreq))))
                            ((= i ninterfaces))
                         (let* ((name (%get-cstring (pref p :lifreq.lifr_name)))
                                (address-family (pref p :lifreq.lifr_lifru.lifru_addr.ss_family))
                                (if-flags nil)
                                (address nil)
                                (netmask nil))
                           (if (>= (#_ioctl sock os::SIOCGLIFFLAGS :address p)
                                   0)
                             (setq if-flags (pref p :lifreq.lifr_lifru.lifru_flags)))
                           (if (>= (#_ioctl sock os::SIOCGLIFADDR :address p)
                                   0)
                             (setq address (pref
                                            (pref p :lifreq.lifr_lifru.lifru_addr)
                                            #>sockaddr_in.sin_addr.S_un.S_addr)))
                           (if (>= (#_ioctl sock os::SIOCGLIFNETMASK :address p)
                                   0)
                             (setq netmask (pref
                                            (pref p :lifreq.lifr_lifru.lifru_subnet)
                                            #>sockaddr_in.sin_addr.S_un.S_addr)))
                             
                           (push (make-ip-interface
                                  :name name
                                  :addr (ntohl address)
                                  :netmask (ntohl netmask)
                                  :flags if-flags
                                  :address-family address-family)
                                 res)))))))))
        (fd-close sock)))
    res))
)




#+windows-target
(defun %get-ip-interfaces ()
  (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
    (unwind-protect
         (rlet ((realoutlen #>DWORD 0))
           (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
                              (* 2 reservedlen)))
                ()
             (%stack-block ((buf reservedlen))
               (if (eql 0  (#_WSAIoctl
                            socket
                            #$SIO_GET_INTERFACE_LIST
                            (%null-ptr)
                            0
                            buf
                            reservedlen
                            realoutlen
                            (%null-ptr)
                            (%null-ptr)))
               (let* ((noutbytes (pref realoutlen #>DWORD)))
                 (when (< noutbytes reservedlen)
                   (let* ((interfaces nil))

                     (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO)))
                           (nameidx 0 (1+ nameidx)))
                          ((>= offset noutbytes))
                       (with-macptrs ((p (%inc-ptr buf offset)))
                         (push (make-ip-interface 
                                :name (format nil "ip~d" nameidx)
                                :addr (ntohl
                                       (pref (pref p #>INTERFACE_INFO.iiAddress)
                                             #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
                                :netmask (ntohl
                                          (pref (pref p #>INTERFACE_INFO.iiNetmask)
                                                #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
                                :flags (pref p #>INTERFACE_INFO.iiFlags)
                                :address-family #$AF_INET)
                               interfaces)))
                     (return interfaces))))
               (let* ((err (#_WSAGetLastError)))
                 (unless (eql err #$WSAEFAULT)
                   (return)))))))
      (#_closesocket socket))))

      


(defloadvar *ip-interfaces* ())

(defun ip-interfaces ()
  (or *ip-interfaces*
      (setq *ip-interfaces* (%get-ip-interfaces))))

;;; This should presumably happen after a configuration change.
;;; How do we detect a configuration change ?
(defun %reset-ip-interfaces ()
  (setq *ip-interfaces* ()))

;;; Return the first non-loopback interface that's up and whose address
;;; family is #$AF_INET.  If no such interface exists, return
;;; the loopback interface.
(defun primary-ip-interface ()
  (let* ((ifaces (ip-interfaces)))
    (or (find-if #'(lambda (i)
		     (and (eq #$AF_INET (ip-interface-address-family i))
                          (ip-interface-addr i)
			  (let* ((flags (ip-interface-flags i)))
			    (and (not (logtest #$IFF_LOOPBACK flags))
				 (logtest #$IFF_UP flags)))))
		 ifaces)
	(car ifaces))))

(defun primary-ip-interface-address ()
  (let* ((iface (primary-ip-interface)))
    (if iface
      (ip-interface-addr iface)
      (error "Can't determine primary IP interface"))))
	  
	  
(defmethod stream-io-error ((stream socket) errno where)
  (socket-error stream where errno nil))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun snarf-url (url &key max-redirects (user-agent "CCL") &aux conn)
  "GET the contents of the url as a (VECTOR (UNSIGNED-BYTE 8))"
  (labels ((is-prefix (prefix string) (eql (length prefix) (string-lessp prefix string)))
	   (header (prefix lines)
	     (let ((line (find prefix lines :test #'is-prefix)))
	       (and line (string-trim ccl::wsp (subseq line (length prefix))))))
	   (header-value (prefix lines)
	     (let ((line (find prefix lines :test #'is-prefix)))
	       (and line (parse-integer line :start (length prefix)))))
	   (split-url (string)
             (if (is-prefix "/" string)
               (list nil 80 string)
               (if (not (is-prefix "http://" string))
                 (error "Unknown scheme in ~s" string)
                 (let* ((start (length "http://"))
                        (end (length string))
                        (ppos (or (position #\/ string :start start) end))
                        (hend (or (position #\: string :start start :end ppos) ppos)))
                   (list (subseq string start hend)
                         (if (< hend ppos) (parse-integer string :start (1+ hend) :end ppos) 80)
                         (if (< ppos end) (subseq string ppos) "/"))))))
	   (read-header (conn)
	     (loop as lines = (loop for line = (read-line conn nil)
				    until (= 0 (length line)) ; eof or empty line
				    collect line)
		   as status = (let ((status-line (pop lines)))
				 (or (parse-integer status-line
						    :start (position #\Space status-line)
						    :junk-allowed t)
				     0))
		   while (= status 100)
		   finally (return (values lines status)))))
    (unwind-protect
       (loop with original-url = url
	     with redirects = (or max-redirects 20)
	     with (host port path) = (split-url original-url)
	     do (setq conn (make-socket :remote-host host
					:remote-port port
					:external-format '(:character-encoding :us-ascii
							   :line-termination :crlf)))
	     do (format conn "GET ~a HTTP/1.1~%Host: ~a:~d~%Connection: close~%User-Agent: ~a~2%"
			path host port user-agent)
	     do (finish-output conn)
	     do (multiple-value-bind (header-lines status) (read-header conn)
		  (when (= status 200)
		    (let ((encoding (header "transfer-encoding:" header-lines)))
		      ;; Here would recognize chunked encoding if cared about that...
		      (when (and encoding (not (string-equal encoding "identity")))
			(error "Unsupported encoding ~s" encoding)))
		    (return
		      (let* ((count (header-value "content-length:" header-lines)))
			(if count
			    (let ((vec (make-array count :element-type '(unsigned-byte 8))))
			      (loop for i from 0 below count
				    do (setf (aref vec i) (read-byte conn)))
			      vec)
			    (let ((vec (make-array 1000
						   :element-type '(unsigned-byte 8)
						   :fill-pointer 0
						   :adjustable t)))
			      (loop for byte = (read-byte conn nil) while byte
				    do (vector-push-extend byte vec))
			      (subseq vec 0 (length vec)))))))
		  (unless (and (<= 300 status 399) (<= 0 (decf redirects)))
		    (if (<= 300 status 399)
			(error "Too many redirects")
			(error "Unknown response ~s" status)))
		  (let* ((new (or (header "location:" header-lines)
				  (error "Missing Location: header"))))
		    (destructuring-bind (new-host new-port new-path) (split-url new)
		      (when new-host
			(setq host new-host port new-port))
		      (setq path new-path))
		    (close conn)
		    (setq conn nil)))
      (when conn (close conn))))))