Initial checkin of common-net.
authorFredrik Tolf <fredrik@dolda2000.com>
Tue, 30 Mar 2010 03:14:34 +0000 (05:14 +0200)
committerFredrik Tolf <fredrik@dolda2000.com>
Tue, 30 Mar 2010 03:14:34 +0000 (05:14 +0200)
charcode.asd [new file with mode: 0644]
charcode.lisp
common-net.asd [new file with mode: 0644]
common-net.lisp [new file with mode: 0644]
net-ecl.lisp [new file with mode: 0644]
net-sb-bsd.lisp [new file with mode: 0644]
net-sbcl.lisp [new file with mode: 0644]

diff --git a/charcode.asd b/charcode.asd
new file mode 100644 (file)
index 0000000..4caf0f9
--- /dev/null
@@ -0,0 +1,2 @@
+(defsystem :charcode
+  :components ((:file "charcode")))
index a572fc2..486e679 100644 (file)
   (declare (type character char))
   (char-code char))
 
   (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)))
 ;;; 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 (file)
index 0000000..5546fc8
--- /dev/null
@@ -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 (file)
index 0000000..84607c5
--- /dev/null
@@ -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 (file)
index 0000000..3f80737
--- /dev/null
@@ -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 (file)
index 0000000..044f7d1
--- /dev/null
@@ -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 (file)
index 0000000..0ff03cf
--- /dev/null
@@ -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)