Skip to content

Instantly share code, notes, and snippets.

@hanshuebner

hanshuebner/gist:4573c0bd258c507aeaee

Created September 18, 2014 15:58
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save hanshuebner/4573c0bd258c507aeaee to your computer and use it in GitHub Desktop.
Save hanshuebner/4573c0bd258c507aeaee to your computer and use it in GitHub Desktop.
Download ZIP
l1-sockets.lisp with initial ipv6 support
Raw
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))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment