Newer
Older
;;; -*- Log: code.log; Package: extensions -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.8 1992/02/16 13:53:47 wlott Exp $")
;;; **********************************************************************
;;;
;;; This file contains an interface to internet domain sockets.
;;;
;;; Written by William Lott.
;;;
(in-package "EXTENSIONS")
(use-package "ALIEN")
(use-package "C-CALL")
(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))
(defconstant sock-stream 1)
(defconstant sock-dgram 2)
(defconstant sock-raw 3)
(defconstant af-unix 1)
(defconstant af-inet 2)
(defconstant msg-oob 1)
(defconstant msg-peek 2)
(defconstant msg-dontroute 4)
(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))))
(ecase (c:backend-byte-order c:*backend*)
(:big-endian
var)
(:little-endian
(let ((ldbs nil))
(dotimes (i bytes `(logior ,@ldbs))
(push `(ash (ldb (byte 8 ,(* i 8)) ,var)
,(* (- bytes 1 i) 8))
ldbs))))))
(proclaim '(inline htonl ntohl htons ntohs))
(defun htonl (x)
(maybe-byte-swap x 4))
(defun ntohl (x)
(maybe-byte-swap x 4))
(defun htons (x)
(maybe-byte-swap x 2))
(defun ntohs (x)
(maybe-byte-swap x 2))
;;;; Host entry operations.
(defstruct host-entry
name
aliases
addr-type
addr-list)
(defun host-entry-addr (host)
(declare (type host-entry host))
(def-alien-type inet-sockaddr
(struct nil
(family short)
(port unsigned-short)
(addr unsigned-long)
(zero (array char 8))))
(def-alien-type hostent
(struct nil
(name c-string)
(aliases (* c-string))
(addrtype int)
(length int)
(addr-list (* (unsigned 32)))))
(def-alien-routine "gethostbyname" (* hostent)
(name c-string))
(def-alien-routine "gethostbyaddr" (* hostent)
(addr unsigned-long :copy)
(defmacro listify-c-array (array)
`(do ((results nil (cons (deref ,array index) results))
(index 0 (1+ index)))
((zerop (deref (cast ,array (* (unsigned 32))) index))
(nreverse results))))
(defun lookup-host-entry (host)
(if (typep host 'host-entry)
host
(with-alien
((hostent (* hostent)
(etypecase host
(string
(gethostbyname host))
((unsigned-byte 32)
(gethostbyaddr host 4 af-inet)))))
(unless (zerop (sap-int (alien-sap hostent)))
:name (slot hostent 'name)
:aliases (listify-c-array (slot hostent 'aliases))
:addr-type (slot hostent 'addrtype)
:addr-list (listify-c-array (slot hostent 'addr-list)))))))
(defun create-inet-socket (&optional (kind :stream))
(multiple-value-bind (proto type)
(internet-protocol kind)
(let ((socket (unix:unix-socket af-inet type proto)))
(error "Error creating socket: ~A" (unix:get-unix-error-msg)))
socket)))
(defun connect-to-inet-socket (host port &optional (kind :stream))
(let ((socket (create-inet-socket kind))
(hostent (or (lookup-host-entry host)
(error "Unknown host: ~S." host))))
(with-alien ((sockaddr inet-sockaddr))
(setf (slot sockaddr 'family) af-inet)
(setf (slot sockaddr 'port) (htons port))
(setf (slot sockaddr 'addr) (host-entry-addr hostent))
(when (minusp (unix:unix-connect socket
(alien-sap sockaddr)
(alien-size inet-sockaddr :bytes)))
(unix:unix-close socket)
(error "Error connecting socket to [~A:~A]: ~A"
(host-entry-name hostent)
port
socket)))
(defun create-inet-listener (port &optional (kind :stream))
(let ((socket (create-inet-socket kind)))
(with-alien ((sockaddr inet-sockaddr))
(setf (slot sockaddr 'family) af-inet)
(setf (slot sockaddr 'port) (htons port))
(setf (slot sockaddr 'addr) 0)
(when (minusp (unix:unix-bind socket
(alien-sap sockaddr)
(alien-size inet-sockaddr :bytes)))
(unix:unix-close socket)
(when (minusp (unix:unix-listen socket 5))
(unix:unix-close socket)
(error "Error listening to socket: ~A" (unix:get-unix-error-msg))))
socket))
(defun accept-tcp-connection (unconnected)
(declare (fixnum unconnected))
(with-alien ((sockaddr inet-sockaddr))
(let ((connected (unix:unix-accept unconnected
(alien-sap sockaddr)
(alien-size inet-sockaddr :bytes))))
(error "Error accepting a connection: ~A" (unix:get-unix-error-msg)))
(values connected (slot sockaddr 'addr)))))
(defun close-socket (socket)
(multiple-value-bind (ok err)
(error "Error closing socket: ~A" (unix:get-unix-error-msg err))))
;;;; 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))
(cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob))
(cerror "Ignore it"
"Error recving oob data on ~A: ~A"
(car handlers)
(t
(setf handled t)
(let ((char (schar buffer 0))
(handled nil))
(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.")))
;;; 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)
(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 unix:sigurg #'sigurg-handler)
(unix:unix-fcntl fd unix:f-setown (unix: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)
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
(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)
(let ((buffer (make-string 1 :initial-element char)))
(declare (simple-string buffer))
(when (minusp (unix:unix-send fd buffer 1 msg-oob))
(error "Error sending ~S OOB to across ~A: ~A"
char
fd