Skip to content
Snippets Groups Projects
internet.lisp 9.37 KiB
Newer Older
ram's avatar
ram committed
;;; -*- 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 $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;; This file contains an interface to internet domain sockets.
;;;
;;; Written by William Lott.
;;;

(in-package "EXTENSIONS")

(use-package "ALIEN")
(use-package "C-CALL")

ram's avatar
ram committed
(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))


wlott's avatar
wlott committed
(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)

ram's avatar
ram committed
(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))))


wlott's avatar
wlott committed
(defmacro maybe-byte-swap (var bytes)
  (ecase (c:backend-byte-order c:*backend*)
wlott's avatar
wlott committed
    (: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))
ram's avatar
ram committed


;;;; Host entry operations.

(defstruct host-entry
  name
  aliases
  addr-type
  addr-list)

(defun host-entry-addr (host)
  (declare (type host-entry host))
ram's avatar
ram committed
  (car (host-entry-addr-list 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)
ram's avatar
ram committed
  (len int)
  (type int))

(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))))
ram's avatar
ram committed

(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)))
ram's avatar
ram committed
	  (make-host-entry
	   :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)))))))
ram's avatar
ram committed

(defun create-inet-socket (&optional (kind :stream))
  (multiple-value-bind (proto type)
		       (internet-protocol kind)
    (let ((socket (unix:unix-socket af-inet type proto)))
wlott's avatar
wlott committed
      (when (minusp socket)
	(error "Error creating socket: ~A" (unix:get-unix-error-msg)))
ram's avatar
ram committed
      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)
ram's avatar
ram committed
	(error "Error connecting socket to [~A:~A]: ~A"
	       (host-entry-name hostent)
	       port
	       (unix:get-unix-error-msg)))
ram's avatar
ram committed
      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)
ram's avatar
ram committed
	(error "Error binding socket to port ~a: ~a"
	       port
	       (unix:get-unix-error-msg))))
ram's avatar
ram committed
    (when (eq kind :stream)
      (when (minusp (unix:unix-listen socket 5))
	(unix:unix-close socket)
	(error "Error listening to socket: ~A" (unix:get-unix-error-msg))))
ram's avatar
ram committed
    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))))
wlott's avatar
wlott committed
      (when (minusp connected)
	(error "Error accepting a connection: ~A" (unix:get-unix-error-msg)))
      (values connected (slot sockaddr 'addr)))))
ram's avatar
ram committed

(defun close-socket (socket)
  (multiple-value-bind (ok err)
		       (unix:unix-close socket)
ram's avatar
ram committed
    (unless ok
      (error "Error closing socket: ~A" (unix:get-unix-error-msg err))))
wlott's avatar
wlott committed
  (undefined-value))
ram's avatar
ram committed



;;;; 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))
wlott's avatar
wlott committed
	     (cerror "Ignore it"
		     "Error recving oob data on ~A: ~A"
		     (car handlers)
		     (unix:get-unix-error-msg)))
wlott's avatar
wlott committed
	    (t
	     (setf handled t)
	     (let ((char (schar buffer 0))
		   (handled nil))
	       (declare (base-char char))
wlott's avatar
wlott committed
	       (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)))))))
ram's avatar
ram committed
    (unless handled
      (cerror "Ignore it"
	      "Got a SIGURG, but couldn't find any out-of-band data.")))
wlott's avatar
wlott committed
  (undefined-value))
ram's avatar
ram committed

;;; 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)
	   (base-char char))
ram's avatar
ram committed
  (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)))))
ram's avatar
ram committed
  (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)
	   (base-char char))
ram's avatar
ram committed
  (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)
	   (base-char char))
ram's avatar
ram committed
  (let ((buffer (make-string 1 :initial-element char)))
    (declare (simple-string buffer))
    (when (minusp (unix:unix-send fd buffer 1 msg-oob))
wlott's avatar
wlott committed
      (error "Error sending ~S OOB to across ~A: ~A"
	     char
	     fd
	     (unix:get-unix-error-msg)))))