From: Fredrik Tolf Date: Tue, 30 Mar 2010 03:14:34 +0000 (+0200) Subject: Initial checkin of common-net. X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=commitdiff_plain;h=dfa6197cf07772bba6cc056c35672b7f8c4d0f3b Initial checkin of common-net. --- diff --git a/charcode.asd b/charcode.asd new file mode 100644 index 0000000..4caf0f9 --- /dev/null +++ b/charcode.asd @@ -0,0 +1,2 @@ +(defsystem :charcode + :components ((:file "charcode"))) diff --git a/charcode.lisp b/charcode.lisp index a572fc2..486e679 100644 --- a/charcode.lisp +++ b/charcode.lisp @@ -207,6 +207,18 @@ (declare (type character char)) (char-code char)) +#+ecl +(defun unicode->char (unicode) + (declare (type (unsigned-byte 24) unicode)) + (when (>= unicode 256) + (error "ECL does not handle Unicode characters outside Latin-1.")) + (code-char unicode)) + +#+ecl +(defun char->unicode (char) + (declare (type character char)) + (char-code char)) + ;;; ASCII (defun decode-ascii (byteseq charseq &key (start 0) (end (length byteseq))) diff --git a/common-net.asd b/common-net.asd new file mode 100644 index 0000000..5546fc8 --- /dev/null +++ b/common-net.asd @@ -0,0 +1,8 @@ +(defsystem :common-net + :serial t + :depends-on (:charcode) + :components ((:file "common-net") + #+sbcl (:file "net-sbcl") + #+ecl (:file "net-ecl") + #+(or sbcl ecl) (:file "net-sb-bsd") ; ECL uses SB-BSD-SOCKETS + #+clisp (:file "net-clisp"))) diff --git a/common-net.lisp b/common-net.lisp new file mode 100644 index 0000000..84607c5 --- /dev/null +++ b/common-net.lisp @@ -0,0 +1,467 @@ +;;;; COMMON-NET -- Abstract networking library + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :common-net) + (defpackage :common-net + (:nicknames :net) + (:use :cl)))) +(in-package :common-net) + +;;; General declarations + +(defvar *parseable-formats* '()) + +(defclass address () ()) + +(defclass host-address (address) ()) + +(defclass inet-address (address) ()) + +(defclass inet-host-address (inet-address host-address) ()) + +(defgeneric format-address (address)) +(defgeneric connect-to-address (target &key local)) +(defgeneric bind-to-address (address)) +(defgeneric close-socket (socket)) +(defgeneric socket-open-p (socket)) +(defgeneric socket-local-address (socket)) +(defgeneric socket-remote-address (socket)) + +(defclass socket () ()) +(defclass listen-socket (socket) ()) +(defclass stream-socket (socket) ; Gray stream superclasses are added for implementations that support it. + ((mode :initform :byte) + (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t) + :type (array (unsigned-byte 8))) + (byte-read-pos :initform 0 :type integer) + (byte-write-pos :initform 0 :type integer) + (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0) + :type (array character)) + (char-read-pos :initform 0 :type integer) + encoder decoder)) +(defclass datagram-socket (socket) ()) + +(defgeneric accept (socket)) +(defgeneric socket-send (socket data &key start end no-hang)) +(defgeneric socket-send-to (socket data dest &key start end from no-hang)) +(defgeneric socket-recv-into (socket buf &key start end no-hang)) +(defgeneric socket-recv (socket &key no-hang max-len)) + +(defgeneric stream-socket-mode (socket)) +(defgeneric stream-socket-decode-characters (socket charset)) + +(defmethod socket-recv ((socket socket) &key no-hang (max-len 65536)) + (let ((buf (make-array (list max-len) :element-type '(unsigned-byte 8)))) + (multiple-value-bind (len from to) + (socket-recv-into socket buf :no-hang no-hang) + (if (null len) + (values nil nil nil) + (values (subseq buf 0 len) from to))))) + +(defun resolve-address (address) + (etypecase address + (address address) + (string + (dolist (fmt *parseable-formats*) + (handler-case (return (funcall (cdr fmt) address)) + (error () + nil)))))) + +(defun define-parseable-address (name fun &optional (order '(:last))) + (if (symbolp order) (setf order (list order))) + (let ((newlist (remove-if #'(lambda (o) (eq (car o) name)) *parseable-formats*))) + (setf *parseable-formats* + (ecase (car order) + ((:first) + (cons (cons name fun) newlist)) + ((:last) + (append newlist `((,name . ,fun)))))))) + +(defmethod print-object ((address address) stream) + (if *print-escape* + (format stream "#<~S ~A>" (class-name (class-of address)) (format-address address)) + (princ (format-address address) stream)) + address) + +(export '(address host-address inet-address inet-host-address + format-address resolve-address + connect-to-address bind-to-address close-socket + socket-local-address socket-remote-address + accept socket-send socket-send-to socket-recv-into socket-recv)) + +(defmethod connect-to-address ((target string) &key local) + (connect-to-address (resolve-address target) :local local)) + +(defmethod bind-to-address ((address string)) + (bind-to-address (resolve-address address))) + +(defmethod stream-socket-mode ((socket stream-socket)) + (slot-value socket 'mode)) + +(defmethod stream-socket-decode-characters ((socket stream-socket) charset) + (unless (eq (stream-socket-mode socket) :byte) + (simple-socket-error socket "~S is already in character-decoding mode." socket)) + (setf (slot-value socket 'encoder) (charcode:make-encoder charset) + (slot-value socket 'decoder) (charcode:make-decoder charset) + (slot-value socket 'mode) :character)) + +;;; Utility macros + +(defmacro with-open-socket ((var socket) &body body) + (let ((sk (gensym))) + `(let* ((,sk ,socket) + (,var ,sk)) + (unwind-protect (locally ,@body) + (close-socket ,sk))))) + +(defmacro with-connection ((var target &key local charset) &body body) + `(with-open-socket (,var (connect-to-address ,target :local ,local)) + ,@(when charset (list `(stream-socket-decode-characters ,var ,charset))) + ,@body)) + +(defmacro with-bound-socket ((var address) &body body) + `(with-open-socket (,var (bind-to-address ,address)) + ,@body)) + +(export '(with-open-socket with-connection with-bound-socket)) + +;;; Common condition types + +(define-condition socket-condition (condition) + ((socket :initarg :socket :type socket))) + +(define-condition address-busy (error) + ((address :initarg :address :type address)) + (:report (lambda (c s) + (format s "The address ~A is busy." (format-address (slot-value c 'address)))))) + +(define-condition connection-refused (error) + ((address :initarg :address :type address)) + (:report (lambda (c s) + (format s "Connection to ~A was refused by the remote host." (format-address (slot-value c 'address)))))) + +(define-condition socket-closed (error socket-condition) () + (:report (lambda (c s) + (format s "The socket ~S is closed." (slot-value c 'socket))))) + +(define-condition socket-disconnected (socket-closed) () + (:report (lambda (c s) + (format s "The socket ~S has been closed from the other side." (slot-value c 'socket))))) + +(define-condition simple-socket-error (simple-error socket-condition) ()) + +(defun simple-socket-error (socket format &rest args) + (error 'simple-socket-error :socket socket :format-control format :format-arguments args)) + +;;; Gray stream implementation for stream sockets + +(define-condition stream-mode-error (socket-condition stream-error error) + ((expected-mode :initarg :expected-mode)) + (:report (lambda (c s) + (with-slots (expected-mode socket) c + (format s "Tried to use ~S in ~A mode, but it is in ~A mode." socket expected-mode (stream-socket-mode socket)))))) + +(defun gray-stream-element-type (socket) + (declare (type stream-socket socket)) + (ecase (slot-value socket 'mode) + ((:byte) '(unsigned-byte 8)) + ((:character) 'character))) + +(defun gray-open-stream-p (socket) + (declare (type stream-socket socket)) + (socket-open-p socket)) + +(defun fill-byte-buffer (socket bytes &optional no-hang) + (declare (type stream-socket socket) + (type fixnum bytes)) + (with-slots (byte-buffer byte-read-pos byte-write-pos) socket + (loop (unless (< (- byte-write-pos byte-read-pos) bytes) (return t)) + (when (< (- (length byte-buffer) byte-read-pos) bytes) + (adjust-array byte-buffer (list (+ byte-read-pos bytes 128)))) + (let ((recv-len (socket-recv-into socket byte-buffer :start byte-write-pos :no-hang no-hang))) + (cond ((null recv-len) + (unless no-hang + (error "~S returned NIL even when called blocking." 'socket-recv-into)) + (return :wait)) + ((= recv-len 0) + (return nil))) + (incf byte-write-pos recv-len))))) + +(defun trim-byte-buffer (socket) + (declare (type stream-socket socket)) + (with-slots (byte-buffer byte-read-pos byte-write-pos) socket + (replace byte-buffer byte-buffer :start2 byte-read-pos :end2 byte-write-pos) + (decf byte-write-pos byte-read-pos) + (setf byte-read-pos 0) + (when (> (length byte-buffer) (* byte-write-pos 2)) + (adjust-array byte-buffer (list byte-write-pos))))) + +(defun gray-stream-read-byte (socket) + (declare (type stream-socket socket)) + (unless (fill-byte-buffer socket 1) + (return-from gray-stream-read-byte :eof)) + (unless (eq (stream-socket-mode socket) :byte) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte)) + (with-slots (byte-buffer byte-read-pos) socket + (prog1 (aref byte-buffer byte-read-pos) + (when (> (incf byte-read-pos) 128) + (trim-byte-buffer socket))))) + +(defun gray-stream-write-byte (socket byte) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :byte) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte)) + (let ((buf (make-array '(1) :element-type '(unsigned-byte 8) :initial-element byte))) + (loop (when (> (socket-send socket buf) 0) + (return))))) + +(defun fill-char-buffer (socket chars &optional no-hang) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (with-slots (decoder byte-buffer byte-read-pos byte-write-pos char-buffer char-read-pos) socket + (loop (unless (< (- (length char-buffer) char-read-pos) chars) (return t)) + (case (fill-byte-buffer socket chars no-hang) + ((nil) (return nil)) + ((:wait) (return :wait))) + (funcall decoder byte-buffer char-buffer :start byte-read-pos :end byte-write-pos) + (setf byte-read-pos 0 + byte-write-pos 0)))) + +(defun trim-char-buffer (socket) + (declare (type stream-socket socket)) + (with-slots (char-buffer char-read-pos) socket + (replace char-buffer char-buffer :start2 char-read-pos) + (decf (fill-pointer char-buffer) char-read-pos) + (setf char-read-pos 0))) + +(defun gray-stream-read-char (socket) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (unless (fill-char-buffer socket 1) + (return-from gray-stream-read-char :eof)) + (with-slots (char-buffer char-read-pos) socket + (prog1 (aref char-buffer char-read-pos) + (when (>= (incf char-read-pos) 64) + (trim-char-buffer socket))))) + +(defun gray-stream-unread-char (socket char) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (with-slots (char-buffer char-read-pos) socket + (when (= char-read-pos 0) + (let ((len (length char-buffer))) + (when (< (array-dimension char-buffer 0) (+ len 16)) + (adjust-array char-buffer (list (setf (fill-pointer char-buffer) (+ len 16))))) + (replace char-buffer char-buffer :start1 16 :end2 len))) + (setf (aref char-buffer (decf char-read-pos)) char) + nil)) + +(defun gray-stream-read-char-no-hang (socket) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (case (fill-char-buffer socket 1) + ((nil) (return-from gray-stream-read-char-no-hang :eof)) + ((:wait) (return-from gray-stream-read-char-no-hang nil))) + (with-slots (char-buffer char-read-pos) socket + (prog1 (aref char-buffer char-read-pos) + (when (>= (incf char-read-pos) 64) + (trim-char-buffer socket))))) + +(defun gray-stream-peek-char (socket) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (unless (fill-char-buffer socket 1) + (return-from gray-stream-peek-char :eof)) + (with-slots (char-buffer char-read-pos) socket + (aref char-buffer char-read-pos))) + +(defun gray-stream-listen (socket) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (case (fill-char-buffer socket 1) + ((nil :wait) (return-from gray-stream-listen nil))) + (with-slots (char-buffer char-read-pos) socket + (aref char-buffer char-read-pos))) + +(defun gray-stream-write-char (socket char) + (declare (type stream-socket socket)) + (unless (eq (stream-socket-mode socket) :character) + (error 'stream-mode-error :stream socket :socket socket :expected-mode :character)) + (with-slots (encoder) socket + (let ((seq (make-array '(1) :element-type 'character :initial-element char)) + (outbuf (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) + (funcall encoder seq outbuf) + (let ((pos 0)) + (loop (unless (< pos (length outbuf)) (return)) + (incf pos (socket-send socket outbuf :start pos))))))) + +(defun gray-stream-read-sequence (socket seq start end) + (declare (type stream-socket socket)) + (ecase (stream-socket-mode socket) + ((:byte) + (fill-byte-buffer socket (- end start)) + (with-slots (byte-buffer byte-read-pos byte-write-pos) socket + (replace seq byte-buffer :start1 start :start2 byte-read-pos :end1 end :end2 byte-write-pos) + (let ((len (min (- end start) (- byte-write-pos byte-read-pos)))) + (when (> (incf byte-read-pos len) 128) + (trim-byte-buffer socket)) + (+ start len)))) + ((:character) + (fill-char-buffer socket (- end start)) + (with-slots (char-buffer char-read-pos) socket + (replace seq char-buffer :start1 start :start2 char-read-pos :end1 end :end2 (length char-buffer)) + (let ((len (min (- end start) (- (length char-buffer) char-read-pos)))) + (when (> (incf char-read-pos len) 128) + (trim-char-buffer socket)) + (+ start len)))))) + +(defmethod gray-stream-write-sequence (socket seq start end) + (declare (type stream-socket socket)) + (let ((end (or end (length seq)))) + (ecase (stream-socket-mode socket) + ((:byte) + (loop (unless (< start end) (return seq)) + (incf start (socket-send socket seq :start start :end end)))) + ((:character) + (with-slots (encoder) socket + (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)) + (pos 0)) + (funcall encoder seq outbuf :start start :end end) + (loop (unless (< pos (length outbuf)) (return seq)) + (incf pos (socket-send socket outbuf :start pos))))))))) + +;;; IPv4 addresses + +(defclass ipv4-address (inet-host-address) + ((bytes :initarg :bytes :type (array (unsigned-byte 8) 4)))) + +(defun make-ipv4-address (o1 o2 o3 o4) + (make-instance 'ipv4-address :bytes (make-array '(4) + :element-type '(unsigned-byte 8) + :initial-contents (list o1 o2 o3 o4)))) + +(defun parse-ipv4-address (string) + (let ((o 0) + (start 0) + (string (concatenate 'string string ".")) + (buf (make-array '(4) :element-type '(unsigned-byte 8)))) + (dotimes (i (length string)) + (let ((ch (elt string i))) + (cond ((eql ch #\.) + (if (< o 4) + (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i))) + (if (and n (<= 0 n 255)) + n + (error "IPv4 dottet-quad numbers must be octets")))) + (setf start (1+ i)) + (incf o)) + (error "Too many octets in IPv4 address"))) + ((char<= #\0 ch #\9) + nil) + (t (error "Invalid character ~S in IPv4 address" ch))))) + (if (< o 4) + (error "Too few octets in IPv4 address") + (make-instance 'ipv4-address :bytes buf)))) + +(define-parseable-address 'ipv4-address #'parse-ipv4-address :first) + +(defmethod format-address ((address ipv4-address)) + (with-slots (bytes) address + (format nil "~D.~D.~D.~D" + (aref bytes 0) + (aref bytes 1) + (aref bytes 2) + (aref bytes 3)))) + +(export '(ipv4-address make-ipv4-address parse-ipv4-address)) + +;;; IPv6 addresses + +(defclass ipv6-address (inet-host-address) + ((bytes :initarg :bytes :type (array (unsigned-byte 8) 16)))) + +(defun parse-ipv6-address (string) + (declare (ignore string)) + (error "IPv6 parsing not implemented yet")) + +(define-parseable-address 'ipv6-address #'parse-ipv6-address :first) + +(export '(ipv6-address parse-ipv6-address)) + +;;; TCP code + +(defclass inet-port-address (inet-address) + ((host :initarg :host :type (or null inet-host-address)) + (port :initarg :port :type (unsigned-byte 16)))) + +(defclass tcp-address (inet-port-address) ()) + +(defmethod format-address ((address tcp-address)) + (with-slots (host port) address + (format nil "~A:~D" (if host (format-address host) "*") port))) + +(defun inet-resolve-colon-port (string) + (let ((colon (position #\: string))) + (if (null colon) + (error "No colon in TCP address")) + (if (find #\: string :start (1+ colon)) + (error "More than one colon in TCP address")) + (let ((port (parse-integer (subseq string (1+ colon)))) + (host (let ((host-part (subseq string 0 colon))) + (if (equal host-part "*") + nil + (resolve-address host-part))))) + (if (not (typep host '(or null inet-host-address))) + (error "Must have an internet address for TCP connections")) + (values host port)))) + +(defun resolve-tcp-colon-port (address) + (multiple-value-bind (host port) + (inet-resolve-colon-port address) + (make-instance 'tcp-address :host host :port port))) + +(define-parseable-address 'tcp-service #'resolve-tcp-colon-port) + +(export '(tcp-address resolve-tcp-colon-port)) + +;;; UDP code + +(defclass udp-address (inet-port-address) ()) + +(defmethod format-address ((address udp-address)) + (with-slots (host port) address + (format nil "~A:~D" (if host (format-address host) "*") port))) + +(defun resolve-udp-colon-port (address) + (multiple-value-bind (host port) + (inet-resolve-colon-port address) + (make-instance 'udp-address :host host :port port))) + +(export '(udp-address resolve-udp-colon-port)) + +;;; Unix sockets + +(defclass local-address (address) + ((path :initarg :path :type pathname))) + +(defmethod format-address ((address local-address)) + (namestring (slot-value address 'path))) + +(defclass local-stream-address (local-address) ()) +(defclass local-seq-address (local-address) ()) +(defclass local-datagram-address (local-address) ()) + +(defun make-local-address (pathspec &optional (type :stream)) + (make-instance (ecase type + ((:stream) 'local-stream-address) + ((:seq) 'local-seq-address) + ((:datagram) 'local-datagram-address)) + :path (pathname pathspec))) + +(export '(local-address make-local-address)) diff --git a/net-ecl.lisp b/net-ecl.lisp new file mode 100644 index 0000000..3f80737 --- /dev/null +++ b/net-ecl.lisp @@ -0,0 +1,73 @@ +(in-package :common-net) + +(require :sb-bsd-sockets) + +;;; Gray stream methods + +;; Redefine stream-socket with Gray superclasses. I know it's ugly, +;; but I just don't know of a better way to do it. +(defclass stream-socket (socket gray:fundamental-input-stream gray:fundamental-output-stream) + ((mode :initform :byte) + (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t) + :type (array (unsigned-byte 8))) + (byte-read-pos :initform 0 :type integer) + (byte-write-pos :initform 0 :type integer) + (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0) + :type (array character)) + (char-read-pos :initform 0 :type integer) + encoder decoder)) + +(macrolet ((simple (name) + `(defmethod + ,(intern (symbol-name name) (find-package :gray)) ((socket stream-socket)) + (,(intern (concatenate 'string "GRAY-" (symbol-name name)) (symbol-package 'stream-socket)) socket))) + (simple-null (name) + `(defmethod + ,(intern (symbol-name name) (find-package :gray)) ((socket stream-socket)) + nil))) + (simple stream-element-type) + (simple open-stream-p) + (simple stream-read-byte) + (simple stream-read-char) + (simple stream-read-char-no-hang) + (simple stream-peek-char) + (simple stream-listen) + (simple-null stream-line-column) + (simple-null stream-finish-output) + (simple-null stream-force-output) + (simple-null stream-clear-output)) + +(defmethod gray:stream-write-byte ((socket stream-socket) byte) + (gray-stream-write-char socket byte)) + +(defmethod gray:stream-unread-char ((socket stream-socket) char) + (gray-stream-unread-char socket char)) + +(defmethod gray:stream-write-char ((socket stream-socket) char) + (gray-stream-write-char socket char)) + +(defmethod gray:close ((socket stream-socket) &key abort) + (declare (ignore abort)) + (prog1 + (call-next-method) + (close-socket socket))) + +(defmethod gray:stream-start-line-p ((socket stream-socket)) + (eql (gray:stream-line-column socket) 0)) + +(defmethod gray:stream-fresh-line ((socket stream-socket)) + (unless (gray:stream-start-line-p socket) + (gray:stream-terpri socket) + t)) + +(defmethod gray:stream-write-string ((socket stream-socket) string &optional (start 0) (end (length string))) + (gray:stream-write-sequence socket string start end)) + +(defmethod gray:stream-terpri ((socket stream-socket)) + (gray:stream-write-char socket #\newline)) + +(defmethod gray:stream-read-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) + (gray-stream-read-sequence socket seq start end)) + +(defmethod gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) + (gray-stream-write-sequence socket seq start end)) diff --git a/net-sb-bsd.lisp b/net-sb-bsd.lisp new file mode 100644 index 0000000..044f7d1 --- /dev/null +++ b/net-sb-bsd.lisp @@ -0,0 +1,239 @@ +(in-package :common-net) + +(defclass sbcl-socket (socket) + ((sb-socket :initarg :sb-socket :type sb-bsd-sockets:socket))) +(defclass sbcl-listen-socket (listen-socket sbcl-socket) ()) +(defclass sbcl-stream-socket (stream-socket sbcl-socket) ()) +(defclass sbcl-datagram-socket (datagram-socket sbcl-socket) ()) + +(defmacro with-sb-socket ((var socket) &body body) + (let ((success (gensym "SUCCESS"))) + `(let ((,var ,socket) + (,success nil)) + (unwind-protect + (multiple-value-prog1 + (progn ,@body) + (setf ,success t)) + (unless ,success + (sb-bsd-sockets:socket-close ,var)))))) + +(defun map-sbcl-to-address (sk address) + (etypecase sk + (sb-bsd-sockets:inet-socket + (let ((host (first address)) + (port (second address))) + (make-instance (ecase (sb-bsd-sockets:socket-type sk) + ((:stream) 'tcp-address) + ((:datagram) 'udp-address)) + :host (if (every #'zerop host) + nil + (make-instance 'ipv4-address :bytes host)) + :port port))))) + +(defun map-address-to-sbcl (sk address) + (etypecase sk + (sb-bsd-sockets:inet-socket + (etypecase address + (inet-port-address + (with-slots (host port) address + (list (etypecase host + (null #(0 0 0 0)) + (ipv4-address (slot-value host 'bytes))) + port))))) + (sb-bsd-sockets:local-socket + (etypecase address + (local-address + (namestring (slot-value address 'path))))))) + +(defun sbcl-socket-type-and-args (address) + (etypecase address + (inet-port-address + (let ((type (etypecase address + (tcp-address :stream) + (udp-address :datagram)))) + (with-slots (host port) address + (etypecase host + (null + ;; This should probably be changed to use IPv6 when SBCL + ;; supports it. At least on Linux, since it supports + ;; v4-mapping, but it is less clear what to do on the + ;; BSDs. + (list 'sb-bsd-sockets:inet-socket :type type)) + (ipv4-address + (list 'sb-bsd-sockets:inet-socket :type type)) + (ipv6-address + (error "SBCL does not support IPv6.")))))) + (inet-host-address + (error "SBCL does not support raw sockets.")) + (local-stream-address + (list 'sb-bsd-sockets:local-socket :type :stream)) + (local-seq-address + (error "SBCL does not support Unix seqpacket sockets.")) + (local-datagram-address + (list 'sb-bsd-sockets:local-socket :type :datagram)))) + +(defun sb-bsd-socket-for-address (address) + (apply #'make-instance (sbcl-socket-type-and-args address))) + +(defun check-not-closed (socket) + (declare (type sbcl-socket socket)) + (when (null (slot-value socket 'sb-socket)) + (error 'socket-closed :socket socket))) + +(define-condition wrapped-socket-error (error socket-condition) + ((cause :initarg :cause)) + (:report (lambda (c s) + (princ (slot-value c 'cause) s)))) + +(defun map-sb-bsd-error (socket c) + (cond ((eql (sb-bsd-sockets::socket-error-errno c) 32) ; EPIPE + (error 'socket-disconnected :socket socket)) + ((eql (sb-bsd-sockets::socket-error-errno c) 104) ; ECONNRESET + (error 'socket-disconnected :socket socket)) + (t (error 'wrapped-socket-error :socket socket :cause c)))) + +(defmacro map-sb-bsd-errors ((socket) &body body) + (let ((c (gensym "C"))) + `(handler-bind ((sb-bsd-sockets:socket-error (lambda (,c) (map-sb-bsd-error ,socket ,c)))) + ,@body))) + +(defmacro retry-loop ((format-string &rest format-args) &body body) + `(loop (with-simple-restart (retry ,format-string ,@format-args) + (return ,@body)))) + +(defmethod close-socket ((socket sbcl-socket)) + (with-slots (sb-socket) socket + (unless (null sb-socket) + (sb-bsd-sockets:socket-close sb-socket) + (setf sb-socket nil)))) + +(defmethod socket-open-p ((socket sbcl-socket)) + (if (slot-value socket 'sb-socket) t nil)) + +(defmethod socket-local-address ((socket sbcl-socket)) + (check-not-closed socket) + (with-slots (sb-socket) socket + (map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-name sb-socket))))) + +(defmethod socket-remote-address ((socket sbcl-socket)) + (check-not-closed socket) + (with-slots (sb-socket) socket + (map-sbcl-to-address sb-socket (multiple-value-list (sb-bsd-sockets:socket-peername sb-socket))))) + +(defmethod socket-send ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang) + (check-not-closed socket) + (let ((result (map-sb-bsd-errors (socket) + (retry-loop ("Retry the send operation.") + (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket) + (if (= start 0) + buf + (subseq buf start end)) + (- end start) + :nosignal t + :dontwait no-hang))))) + (etypecase result + (null 0) + (integer result)))) + +(defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang) + (check-not-closed socket) + (when from + (error "SB-BSD-THREADS does not support specifying the source address of individual packets.")) + (let ((result (map-sb-bsd-errors (socket) + (retry-loop ("Retry the send operation.") + (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket) + (if (= start 0) + buf + (subseq buf start end)) + (- end start) + :address (map-address-to-sbcl socket destination) + :nosignal t + :dontwait no-hang))))) + (etypecase result + (null 0) + (integer result)))) + +(defmethod socket-recv-into ((socket sbcl-socket) buf &key (start 0) (end (length buf)) no-hang) + (check-not-closed socket) + (check-type buf sequence) + (let* ((direct (and (= start 0) (typep buf '(array (unsigned-byte 8))))) + (readbuf (if direct + buf + (make-array (list (- end start)) :element-type '(unsigned-byte 8)))) + (ret-list (multiple-value-list + (map-sb-bsd-errors (socket) + (retry-loop ("Try receiving again.") + (sb-bsd-sockets:socket-receive (slot-value socket 'sb-socket) + readbuf + (- end start) + :dontwait no-hang + :element-type '(unsigned-byte 8)))))) + (len (second ret-list)) + (addr-list (cddr ret-list))) + (etypecase len + (null (values nil nil)) + (integer + (unless direct + (replace buf readbuf :start1 start :end2 len)) + (values len (map-sbcl-to-address (slot-value socket 'sb-socket) addr-list)))))) + +(defmethod bind-to-address ((address tcp-address)) + (make-instance 'sbcl-listen-socket + :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address)) + (handler-bind + ((sb-bsd-sockets:address-in-use-error (lambda (c) + (declare (ignore c)) + (error 'address-busy :address address)))) + (retry-loop ("Try binding again.") + (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address)))) + (sb-bsd-sockets:socket-listen sk 64) + sk))) + +(defmethod connect-to-address ((remote tcp-address) &key local) + (typecase local + (string (setf local (resolve-address local)))) + (make-instance 'sbcl-stream-socket + :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote))) + (if local + (handler-case + (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)) + (sb-bsd-sockets:address-in-use-error () + (error 'address-busy :address local)))) + (retry-loop ("Retry connection.") + (handler-bind + ((sb-bsd-sockets:connection-refused-error (lambda (c) + (declare (ignore c)) + (error 'connection-refused :address remote)))) + (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote)))) + sk))) + +(defmethod bind-to-address ((address udp-address)) + (make-instance 'sbcl-datagram-socket + :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address address)) + (handler-case + (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk address)) + (sb-bsd-sockets:address-in-use-error () + (error 'address-busy :address address))) + sk))) + +(defmethod connect-to-address ((remote udp-address) &key local) + (typecase local + (string (setf local (resolve-address local)))) + (make-instance 'sbcl-datagram-socket + :sb-socket (with-sb-socket (sk (sb-bsd-socket-for-address (if local local remote))) + (if local + (handler-case + (apply #'sb-bsd-sockets:socket-bind sk (map-address-to-sbcl sk local)) + (sb-bsd-sockets:address-in-use-error () + (error 'address-busy :address local)))) + (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote)) + sk))) + +(defmethod accept ((socket sbcl-listen-socket)) + (check-not-closed socket) + (let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket)))) + (sk (first ret-list)) + (addr-list (rest ret-list))) + (with-sb-socket (sk sk) + (values (make-instance 'sbcl-stream-socket :sb-socket sk) + (map-sbcl-to-address sk addr-list))))) diff --git a/net-sbcl.lisp b/net-sbcl.lisp new file mode 100644 index 0000000..0ff03cf --- /dev/null +++ b/net-sbcl.lisp @@ -0,0 +1,78 @@ +(in-package :common-net) + +(require :sb-bsd-sockets) + +;;; Gray stream methods + +;; Redefine stream-socket with Gray superclasses. I know it's ugly, +;; but I just don't know of a better way to do it. +(defclass stream-socket (socket sb-gray:fundamental-input-stream sb-gray:fundamental-output-stream) + ((mode :initform :byte) + (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t) + :type (array (unsigned-byte 8))) + (byte-read-pos :initform 0 :type integer) + (byte-write-pos :initform 0 :type integer) + (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0) + :type (array character)) + (char-read-pos :initform 0 :type integer) + encoder decoder)) + +(macrolet ((simple (name) + `(defmethod + ,(intern (symbol-name name) (find-package :sb-gray)) ((socket stream-socket)) + (,(intern (concatenate 'string "GRAY-" (symbol-name name)) (symbol-package 'stream-socket)) socket))) + (simple-null (name) + `(defmethod + ,(intern (symbol-name name) (find-package :sb-gray)) ((socket stream-socket)) + nil))) + (simple stream-element-type) + (simple open-stream-p) + (simple stream-read-byte) + (simple stream-read-char) + (simple stream-read-char-no-hang) + (simple stream-peek-char) + (simple stream-listen) + (simple-null stream-line-column) + (simple-null stream-finish-output) + (simple-null stream-force-output) + (simple-null stream-clear-output)) + +(defmethod sb-gray:stream-write-byte ((socket stream-socket) byte) + (gray-stream-write-char socket byte)) + +(defmethod sb-gray:stream-unread-char ((socket stream-socket) char) + (gray-stream-unread-char socket char)) + +(defmethod sb-gray:stream-write-char ((socket stream-socket) char) + (gray-stream-write-char socket char)) + +(defmethod close ((socket stream-socket) &key abort) + (declare (ignore abort)) + (prog1 + (call-next-method) + (close-socket socket))) + +(defmethod sb-gray:stream-start-line-p ((socket stream-socket)) + (eql (sb-gray:stream-line-column socket) 0)) + +(defmethod sb-gray:stream-fresh-line ((socket stream-socket)) + (unless (sb-gray:stream-start-line-p socket) + (sb-gray:stream-terpri socket) + t)) + +(defmethod sb-gray:stream-write-string ((socket stream-socket) string &optional (start 0) (end (length string))) + (sb-gray:stream-write-sequence socket string start end)) + +(defmethod sb-gray:stream-terpri ((socket stream-socket)) + (sb-gray:stream-write-char socket #\newline)) + +(defmethod sb-gray:stream-read-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) + (gray-stream-read-sequence socket seq start end)) + +(defmethod sb-gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq))) + (gray-stream-write-sequence socket seq start end)) + +;;; Necessary SBCL gray-stream extensions + +(defmethod sb-gray:stream-line-length ((socket stream-socket)) + nil)