diff --git a/code/internet.lisp b/code/internet.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a01e8e1b254bf86ced7a4a1d8d10cfb9571c6993 --- /dev/null +++ b/code/internet.lisp @@ -0,0 +1,424 @@ +;;; -*- Log: code.log; Package: extensions -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains an interface to internet domain sockets. +;;; +;;; Written by William Lott. +;;; + +(in-package "EXTENSIONS") + +(export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name + host-entry-aliases host-entry-addr-list host-entry-addr + create-inet-socket connect-to-inet-socket create-inet-listener + accept-tcp-connection close-socket ipproto-tcp ipproto-udp inaddr-any + add-oob-handler remove-oob-handler remove-all-oob-handlers + send-character-out-of-band)) + + +(defvar *internet-protocols* + (list (list :stream 6 sock-stream) + (list :data-gram 17 sock-dgram)) + "AList of socket kinds and protocol values.") + +(defun internet-protocol (kind) + (let ((entry (assoc kind *internet-protocols*))) + (unless entry + (error "Invalid kind (~S) for internet domain sockets." kind)) + (values (cadr entry) + (caddr entry)))) + + + +(eval-when (compile load eval) + #+ :IBM-RT-PC + (pushnew :NETWORK-BYTE-ORDER *features*) + ) + +#+ :NETWORK-BYTE-ORDER +(progn + (defmacro htonl (x) x) + (defmacro ntohl (x) x) + (defmacro htons (x) x) + (defmacro ntohs (x) x)) + +#- :NETWORK-BYTE-ORDER +(progn + (defmacro htonl (x) + (let ((val (gensym))) + `(let ((,val ,x)) + (logior (ash (ldb (byte 8 0) + ,val) + 24) + (ash (ldb (byte 8 8) + ,val) + 16) + (ash (ldb (byte 8 16) + ,val) + 8) + (ldb (byte 8 24) + ,val))))) + (defmacro ntohl (x) + `(htonl ,x)) + (defmacro htons (x) + (let ((val (gensym))) + `(let ((,val ,x)) + (logior (ash (ldb (byte 8 0) + ,val) + 8) + (ldb (byte 8 8) + ,val))))) + (defmacro ntohs (x) + `(htons ,x))) + + + +;;;; Host entry operations. + +(defstruct host-entry + name + aliases + addr-type + addr-list) + +(defun host-entry-addr (host) + (car (host-entry-addr-list host))) + + +(def-c-pointer *char (null-terminated-string 256)) +(def-c-type pointer (unsigned-byte 32)) + +(def-c-record inet-sockaddr + (family short) + (port unsigned-short) + (addr unsigned-long) + (zero (unsigned-byte 64))) + +(def-c-record hostent + (name *char) + (aliases pointer) + (addrtype int) + (length int) + (addr_list pointer)) + +(def-c-routine "gethostbyname" (*hostent) + (name *char)) +(def-c-routine "gethostbyaddr" (*hostent) + (addr pointer) + (len int) + (type int)) + +(defalien *alien-ulong* (unsigned-byte 32) 32) +(defalien *alien-sockaddr* inet-sockaddr (c-sizeof 'inet-sockaddr)) + +(defoperator (my-hostent-aliases pointer) + ((hostent hostent)) + `(alien-index (alien-value ,hostent) + (long-words 1) + (long-words 1))) + +(defoperator (my-hostent-addr_list pointer) + ((hostent hostent)) + `(alien-index (alien-value ,hostent) + (long-words 4) + (long-words 1))) + +(defoperator (pointer-index pointer) + ((pointer pointer) + index) + `(alien-index (alien-value ,pointer) + (long-words ,index) + (long-words 1))) + +(defoperator (pointer-indirect pointer) + ((pointer pointer) + index) + `(alien-indirect (alien-index (alien-value ,pointer) + 0 + (long-words 1)) + (long-words (1+ ,index)))) + +(defun mumble (array) + (alien-bind ((foo array pointer t) + (bar (pointer-indirect (alien-value foo) 0) pointer t) + (baz (pointer-index (alien-value bar) 0) pointer t)) + (alien-value baz))) + +(defoperator (deref-string-ptr (null-terminated-string 512)) + ((alien pointer)) + `(alien-indirect (alien-value ,alien) + (bytes 512))) + +(defoperator (deref-ulong-ptr (unsigned-byte 32)) + ((alien pointer)) + `(alien-indirect (alien-value ,alien) + (long-words 1))) + +(defmacro listify-c-array (array derefer) + (let ((results (gensym)) + (index (gensym)) + (p1 (gensym)) + (p2 (gensym)) + (p3 (gensym))) + `(let ((,results nil) + (,index 0)) + (loop + (alien-bind + ((,p1 (pointer-indirect ,array ,index) pointer t) + (,p2 (pointer-index (alien-value ,p1) ,index) pointer t) + (,p3 (,derefer (alien-value ,p2)))) + (when (zerop (alien-address (alien-value ,p3))) + (return (nreverse ,results))) + (push (alien-access (alien-value ,p3)) + ,results)) + (incf ,index))))) + +(defun lookup-host-entry (host) + (if (typep host 'host-entry) + host + (let ((hostent + (typecase host + (string + (gethostbyname host)) + ((unsigned-byte 32) + (setf (system:alien-access *alien-ulong*) host) + (gethostbyaddr (system:alien-sap *alien-ulong*) + 4 ; bytes per ulong + af-inet)) + (t + (error "Invalid host ~S for ~S -- must be either a string or (unsigned-byte 32)"))))) + (if (not (null hostent)) + (alien-bind ((alien hostent hostent t) + (name + (alien-access (hostent-name (alien-value alien)) + '(alien (null-terminated-string 256) + 2048)) + (null-terminated-string 256) + t) + (aliases + (my-hostent-aliases (alien-value alien)) + pointer + t) + (addr-list + (my-hostent-addr_list (alien-value alien)) + pointer + t)) + (make-host-entry + :name (alien-access (alien-value name)) + :aliases (listify-c-array (alien-value aliases) deref-string-ptr) + :addr-type (alien-access (hostent-addrtype (alien-value alien))) + :addr-list (listify-c-array (alien-value addr-list) + deref-ulong-ptr))))))) + +(defun fill-in-sockaddr (addr port) + (setf (alien-access (inet-sockaddr-family (alien-value *alien-sockaddr*))) + af-inet) + (setf (alien-access (inet-sockaddr-port (alien-value *alien-sockaddr*))) + port) + (setf (alien-access (inet-sockaddr-addr (alien-value *alien-sockaddr*))) + addr) + (values)) + +(defun create-inet-socket (&optional (kind :stream)) + (multiple-value-bind (proto type) + (internet-protocol kind) + (multiple-value-bind (socket err) + (unix-socket af-inet type proto) + (when (null socket) + (error "Error creating socket: ~A" + (get-unix-error-msg err))) + socket))) + +(defun connect-to-inet-socket (host port &optional (kind :stream)) + (let ((socket (create-inet-socket kind)) + (hostent (lookup-host-entry host))) + (fill-in-sockaddr (host-entry-addr hostent) port) + (multiple-value-bind (ok err) + (unix-connect socket + *alien-sockaddr*) + (unless ok + (unix-close socket) + (error "Error connecting socket to [~A:~A]: ~A" + (host-entry-name hostent) + port + (get-unix-error-msg err))) + socket))) + +(defun create-inet-listener (port &optional (kind :stream)) + (let ((socket (create-inet-socket kind))) + (fill-in-sockaddr 0 port) + (multiple-value-bind (ok err) + (unix-bind socket + *alien-sockaddr*) + (unless ok + (unix-close socket) + (error "Error binding socket to port ~a: ~a" + port + (get-unix-error-msg err)))) + (when (eq kind :stream) + (multiple-value-bind (ok err) + (unix-listen socket 5) + (unless ok + (unix-close socket) + (error "Error listening to socket: ~a" + (get-unix-error-msg err))))) + socket)) + +(defun accept-tcp-connection (unconnected) + (declare (fixnum unconnected)) + (multiple-value-bind (connected err) + (unix-accept unconnected + *alien-sockaddr*) + (when (null connected) + (error "Error accepting a connection: ~a" + (get-unix-error-msg err))) + (values connected + (alien-access (inet-sockaddr-addr *alien-sockaddr*))))) + +(defun close-socket (socket) + (multiple-value-bind (ok err) + (unix-close socket) + (unless ok + (error "Error closing socket: ~a" + (get-unix-error-msg err)))) + (values)) + + + +;;;; Out of Band Data. + + +;;; Two level AList. First levels key is the file descriptor, second levels +;;; key is the character. The datum is the handler to call. + +(defvar *oob-handlers* nil) + +;;; SIGURG-HANDLER -- internal +;;; +;;; Routine that gets called whenever out-of-band data shows up. Checks each +;;; file descriptor for any oob data. If there is any, look for a handler for +;;; that character. If any are found, funcall them. + +(defun sigurg-handler (signo code scp) + (declare (ignore signo code scp)) + (let ((buffer (make-string 1)) + (handled nil)) + (declare (simple-string buffer)) + (dolist (handlers *oob-handlers*) + (declare (list handlers)) + (multiple-value-bind (value err) + (mach:unix-recv (car handlers) + buffer + 1 + mach:msg-oob) + (cond ((null value) + (cerror "Ignore it" + "Error recving oob data on ~A: ~A" + (car handlers) + (mach:get-unix-error-msg err))) + (t + (setf handled t) + (let ((char (schar buffer 0)) + (handled nil)) + (declare (string-char char)) + (dolist (handler (cdr handlers)) + (declare (list handler)) + (when (eql (car handler) char) + (funcall (cdr handler)) + (setf handled t))) + (unless handled + (cerror "Ignore it" + "No oob handler defined for ~S on ~A" + char + (car handlers)))))))) + (unless handled + (cerror "Ignore it" + "Got a SIGURG, but couldn't find any out-of-band data."))) + (values)) + +;;; ADD-OOB-HANDLER -- public +;;; +;;; First, check to see if we already have any handlers for this file +;;; descriptor. If so, just add this handler to them. If not, add this +;;; file descriptor to *oob-handlers*, make sure our interupt handler is +;;; installed, and that the given file descriptor is "owned" by us (so sigurg +;;; will be delivered.) + +(defun add-oob-handler (fd char handler) + "Arange to funcall HANDLER when CHAR shows up out-of-band on FD." + (declare (integer fd) + (string-char char)) + (let ((handlers (assoc fd *oob-handlers*))) + (declare (list handlers)) + (cond (handlers + (push (cons char handler) + (cdr handlers))) + (t + (push (list fd + (cons char + handler)) + *oob-handlers*) + (system:enable-interrupt mach:sigurg #'sigurg-handler) + (mach:unix-fcntl fd mach::f-setown (mach:unix-getpid))))) + (values)) + +;;; REMOVE-OOB-HANDLER -- public +;;; +;;; Delete any handlers for the given char from the list of handlers for the +;;; given file descriptor. If there are no more, nuke the entry for the file +;;; descriptor. + +(defun remove-oob-handler (fd char) + "Remove any handlers for CHAR on FD." + (declare (integer fd) + (string-char char)) + (let ((handlers (assoc fd *oob-handlers*))) + (declare (list handlers)) + (when handlers + (let ((remaining (delete char handlers + :test #'eql + :key #'car))) + (declare (list remaining)) + (if remaining + (setf (cdr handlers) remaining) + (setf *oob-handlers* + (delete fd *oob-handlers* + :test #'eql + :key #'car)))))) + (values)) + +;;; REMOVE-ALL-OOB-HANDLERS -- public +;;; +;;; Delete the entry for the given file descriptor. + +(defun remove-all-oob-handlers (fd) + "Remove all handlers for FD." + (declare (integer fd)) + (setf *oob-handlers* + (delete fd *oob-handlers* + :test #'eql + :key #'car)) + (values)) + +;;; SEND-CHARACTER-OUT-OF-BAND -- public +;;; +;;; Sends CHAR across FD out of band. + +(defun send-character-out-of-band (fd char) + (declare (integer fd) + (string-char char)) + (let ((buffer (make-string 1 :initial-element char))) + (declare (simple-string buffer)) + (multiple-value-bind (value err) + (mach:unix-send fd buffer 1 mach:msg-oob) + (unless value + (error "Error sending ~S OOB to across ~A: ~A" + char + fd + (mach:get-unix-error-msg err))))))