1 ;;;; COMMON-NET -- Abstract networking library
3 (eval-when (:compile-toplevel :load-toplevel :execute)
4 (unless (find-package :common-net)
5 (defpackage :common-net
8 (in-package :common-net)
10 ;;; General declarations
12 (defclass address () ())
13 (defclass host-address (address) ())
15 (defclass inet-address (address) ())
16 (defclass inet-host-address (inet-address host-address) ())
18 (defgeneric format-address (address))
19 (defgeneric connected-address-p (address))
20 (defgeneric connect-to-address (target &key local))
21 (defgeneric bind-to-address (address))
22 (defgeneric close-socket (socket))
23 (defgeneric socket-open-p (socket))
24 (defgeneric socket-local-address (socket))
25 (defgeneric socket-remote-address (socket))
27 (defclass socket () ())
28 (defclass listen-socket (socket) ())
29 (defclass stream-socket (socket) ; Gray stream superclasses are added for implementations that support it.
30 ((mode :initform :byte)
31 (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t)
32 :type (array (unsigned-byte 8)))
33 (byte-read-pos :initform 0 :type integer)
34 (byte-write-pos :initform 0 :type integer)
35 (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)
36 :type (array character))
37 (char-read-pos :initform 0 :type integer)
39 (defclass datagram-socket (socket) ())
41 (defgeneric accept (socket))
42 (defgeneric socket-send (socket data &key start end no-hang))
43 (defgeneric socket-send-to (socket data dest &key start end from no-hang))
44 (defgeneric socket-recv-into (socket buf &key start end no-hang))
45 (defgeneric socket-recv (socket &key no-hang max-len))
47 (defgeneric stream-socket-mode (socket))
48 (defgeneric stream-socket-decode-characters (socket charset))
50 (defmethod socket-recv ((socket socket) &key no-hang (max-len 65536))
51 (let ((buf (make-array (list max-len) :element-type '(unsigned-byte 8))))
52 (multiple-value-bind (len from to)
53 (socket-recv-into socket buf :no-hang no-hang)
56 (values (subseq buf 0 len) from to)))))
58 (defmethod print-object ((address address) stream)
60 (format stream "#<~S ~A>" (class-name (class-of address)) (format-address address))
61 (princ (format-address address) stream))
64 (defmethod connected-address-p ((address inet-host-address))
67 (export '(address host-address inet-address inet-host-address
69 connect-to-address bind-to-address close-socket
70 socket-local-address socket-remote-address
71 accept socket-send socket-send-to socket-recv-into socket-recv))
73 (defmethod stream-socket-mode ((socket stream-socket))
74 (slot-value socket 'mode))
76 (defmethod stream-socket-decode-characters ((socket stream-socket) charset)
77 (unless (eq (stream-socket-mode socket) :byte)
78 (simple-socket-error socket "~S is already in character-decoding mode." socket))
79 (setf (slot-value socket 'encoder) (charcode:make-encoder charset)
80 (slot-value socket 'decoder) (charcode:make-decoder charset)
81 (slot-value socket 'mode) :character))
85 (defmacro with-open-socket ((var socket) &body body)
89 (unwind-protect (locally ,@body)
90 (close-socket ,sk)))))
92 (defmacro with-connection ((var target &key local charset) &body body)
93 `(with-open-socket (,var (connect-to-address ,target :local ,local))
94 ,@(when charset (list `(stream-socket-decode-characters ,var ,charset)))
97 (defmacro with-bound-socket ((var address) &body body)
98 `(with-open-socket (,var (bind-to-address ,address))
101 (export '(with-open-socket with-connection with-bound-socket))
103 ;;; Common condition types
105 (define-condition socket-condition (condition)
106 ((socket :initarg :socket :type socket)))
108 (define-condition network-error (error) ())
110 (define-condition simple-network-error (network-error simple-error) ())
112 (defun simple-network-error (format &rest args)
113 (error 'simple-network-error :format-control format :format-arguments args))
115 (define-condition socket-error (socket-condition network-error) ())
117 (define-condition address-busy (network-error)
118 ((address :initarg :address :type address))
119 (:report (lambda (c s)
120 (format s "The address ~A is busy." (format-address (slot-value c 'address))))))
122 (define-condition connection-refused (network-error)
123 ((address :initarg :address :type address))
124 (:report (lambda (c s)
125 (format s "Connection to ~A was refused by the remote host." (format-address (slot-value c 'address))))))
127 (define-condition socket-closed (socket-error) ()
128 (:report (lambda (c s)
129 (format s "The socket ~S is closed." (slot-value c 'socket)))))
131 (define-condition socket-disconnected (socket-closed) ()
132 (:report (lambda (c s)
133 (format s "The socket ~S has been closed from the other side." (slot-value c 'socket)))))
135 (define-condition simple-socket-error (simple-error socket-error) ())
137 (defun simple-socket-error (socket format &rest args)
138 (error 'simple-socket-error :socket socket :format-control format :format-arguments args))
140 (export '(socket-condition network-error socket-error
141 address-busy connection-refused
142 socket-closed socket-disconnected simple-socket-error))
144 ;;; Gray stream implementation for stream sockets
146 (define-condition stream-mode-error (socket-error stream-error)
147 ((expected-mode :initarg :expected-mode))
148 (:report (lambda (c s)
149 (with-slots (expected-mode socket) c
150 (format s "Tried to use ~S in ~A mode, but it is in ~A mode." socket expected-mode (stream-socket-mode socket))))))
152 (defun gray-stream-element-type (socket)
153 (declare (type stream-socket socket))
154 (ecase (slot-value socket 'mode)
155 ((:byte) '(unsigned-byte 8))
156 ((:character) 'character)))
158 (defun gray-open-stream-p (socket)
159 (declare (type stream-socket socket))
160 (socket-open-p socket))
162 (defun fill-byte-buffer (socket bytes &optional no-hang)
163 (declare (type stream-socket socket)
165 (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
166 (loop (unless (< (- byte-write-pos byte-read-pos) bytes) (return t))
167 (when (< (- (length byte-buffer) byte-read-pos) bytes)
168 (adjust-array byte-buffer (list (+ byte-read-pos bytes 128))))
169 (let ((recv-len (socket-recv-into socket byte-buffer :start byte-write-pos :no-hang no-hang)))
170 (cond ((null recv-len)
172 (error "~S returned NIL even when called blocking." 'socket-recv-into))
176 (incf byte-write-pos recv-len)))))
178 (defun trim-byte-buffer (socket)
179 (declare (type stream-socket socket))
180 (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
181 (replace byte-buffer byte-buffer :start2 byte-read-pos :end2 byte-write-pos)
182 (decf byte-write-pos byte-read-pos)
183 (setf byte-read-pos 0)
184 (when (> (length byte-buffer) (* byte-write-pos 2))
185 (adjust-array byte-buffer (list byte-write-pos)))))
187 (defun gray-stream-read-byte (socket)
188 (declare (type stream-socket socket))
189 (unless (fill-byte-buffer socket 1)
190 (return-from gray-stream-read-byte :eof))
191 (unless (eq (stream-socket-mode socket) :byte)
192 (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte))
193 (with-slots (byte-buffer byte-read-pos) socket
194 (prog1 (aref byte-buffer byte-read-pos)
195 (when (> (incf byte-read-pos) 128)
196 (trim-byte-buffer socket)))))
198 (defun gray-stream-write-byte (socket byte)
199 (declare (type stream-socket socket))
200 (unless (eq (stream-socket-mode socket) :byte)
201 (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte))
202 (let ((buf (make-array '(1) :element-type '(unsigned-byte 8) :initial-element byte)))
203 (loop (when (> (socket-send socket buf) 0)
206 (defun fill-char-buffer (socket chars &optional no-hang)
207 (declare (type stream-socket socket))
208 (unless (eq (stream-socket-mode socket) :character)
209 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
210 (with-slots (decoder byte-buffer byte-read-pos byte-write-pos char-buffer char-read-pos) socket
211 (loop (unless (< (- (length char-buffer) char-read-pos) chars) (return t))
212 (case (fill-byte-buffer socket chars no-hang)
214 ((:wait) (return :wait)))
215 (funcall decoder byte-buffer char-buffer :start byte-read-pos :end byte-write-pos)
216 (setf byte-read-pos 0
219 (defun trim-char-buffer (socket)
220 (declare (type stream-socket socket))
221 (with-slots (char-buffer char-read-pos) socket
222 (replace char-buffer char-buffer :start2 char-read-pos)
223 (decf (fill-pointer char-buffer) char-read-pos)
224 (setf char-read-pos 0)))
226 (defun gray-stream-read-char (socket)
227 (declare (type stream-socket socket))
228 (unless (eq (stream-socket-mode socket) :character)
229 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
230 (unless (fill-char-buffer socket 1)
231 (return-from gray-stream-read-char :eof))
232 (with-slots (char-buffer char-read-pos) socket
233 (prog1 (aref char-buffer char-read-pos)
234 (when (>= (incf char-read-pos) 64)
235 (trim-char-buffer socket)))))
237 (defun gray-stream-unread-char (socket char)
238 (declare (type stream-socket socket))
239 (unless (eq (stream-socket-mode socket) :character)
240 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
241 (with-slots (char-buffer char-read-pos) socket
242 (when (= char-read-pos 0)
243 (let ((len (length char-buffer)))
244 (when (< (array-dimension char-buffer 0) (+ len 16))
245 (adjust-array char-buffer (list (setf (fill-pointer char-buffer) (+ len 16)))))
246 (replace char-buffer char-buffer :start1 16 :end2 len)))
247 (setf (aref char-buffer (decf char-read-pos)) char)
250 (defun gray-stream-read-char-no-hang (socket)
251 (declare (type stream-socket socket))
252 (unless (eq (stream-socket-mode socket) :character)
253 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
254 (case (fill-char-buffer socket 1 t)
255 ((nil) (return-from gray-stream-read-char-no-hang :eof))
256 ((:wait) (return-from gray-stream-read-char-no-hang nil)))
257 (with-slots (char-buffer char-read-pos) socket
258 (prog1 (aref char-buffer char-read-pos)
259 (when (>= (incf char-read-pos) 64)
260 (trim-char-buffer socket)))))
262 (defun gray-stream-peek-char (socket)
263 (declare (type stream-socket socket))
264 (unless (eq (stream-socket-mode socket) :character)
265 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
266 (unless (fill-char-buffer socket 1)
267 (return-from gray-stream-peek-char :eof))
268 (with-slots (char-buffer char-read-pos) socket
269 (aref char-buffer char-read-pos)))
271 (defun gray-stream-listen (socket)
272 (declare (type stream-socket socket))
273 (unless (eq (stream-socket-mode socket) :character)
274 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
275 (case (fill-char-buffer socket 1)
276 ((nil :wait) (return-from gray-stream-listen nil)))
277 (with-slots (char-buffer char-read-pos) socket
278 (aref char-buffer char-read-pos)))
280 (defun gray-stream-write-char (socket char)
281 (declare (type stream-socket socket))
282 (unless (eq (stream-socket-mode socket) :character)
283 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
284 (with-slots (encoder) socket
285 (let ((seq (make-array '(1) :element-type 'character :initial-element char))
286 (outbuf (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
287 (funcall encoder seq outbuf)
289 (loop (unless (< pos (length outbuf)) (return))
290 (incf pos (socket-send socket outbuf :start pos)))))))
292 (defun gray-stream-read-sequence (socket seq start end)
293 (declare (type stream-socket socket))
294 (ecase (stream-socket-mode socket)
296 (fill-byte-buffer socket (- end start))
297 (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
298 (replace seq byte-buffer :start1 start :start2 byte-read-pos :end1 end :end2 byte-write-pos)
299 (let ((len (min (- end start) (- byte-write-pos byte-read-pos))))
300 (when (> (incf byte-read-pos len) 128)
301 (trim-byte-buffer socket))
304 (fill-char-buffer socket (- end start))
305 (with-slots (char-buffer char-read-pos) socket
306 (replace seq char-buffer :start1 start :start2 char-read-pos :end1 end :end2 (length char-buffer))
307 (let ((len (min (- end start) (- (length char-buffer) char-read-pos))))
308 (when (> (incf char-read-pos len) 128)
309 (trim-char-buffer socket))
312 (defmethod gray-stream-write-sequence (socket seq start end)
313 (declare (type stream-socket socket))
314 (let ((end (or end (length seq))))
315 (ecase (stream-socket-mode socket)
317 (loop (unless (< start end) (return seq))
318 (incf start (socket-send socket seq :start start :end end))))
320 (with-slots (encoder) socket
321 (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))
323 (funcall encoder seq outbuf :start start :end end)
324 (loop (unless (< pos (length outbuf)) (return seq))
325 (incf pos (socket-send socket outbuf :start pos)))))))))
329 (defclass ipv4-address (inet-address)
330 ((host-bytes :type (array (unsigned-byte 8) 4))))
332 (defclass ipv4-host-address (ipv4-address inet-host-address) ())
334 (defun parse-dotted-quad (string)
337 (string (concatenate 'string string "."))
338 (buf (make-array '(4) :element-type '(unsigned-byte 8))))
339 (dotimes (i (length string))
340 (let ((ch (elt string i)))
343 (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i)))
344 (if (and n (<= 0 n 255))
346 (error "IPv4 dotted-quad numbers must be octets"))))
349 (error "Too many octets in IPv4 address")))
352 (t (error "Invalid character ~S in IPv4 address" ch)))))
354 (error "Too few octets in IPv4 address")
357 (defmethod initialize-instance :after ((instance ipv4-address) &key host-bytes host-string host-address)
358 (let ((octets (or host-bytes
360 (check-type host-address ipv4-address)
361 (slot-value host-address 'host-bytes))
362 (when host-string (parse-dotted-quad host-string))
364 (assert (and (typep octets 'sequence)
365 (= (length octets) 4)
366 (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
368 (setf (slot-value instance 'host-bytes)
370 :element-type '(unsigned-byte 8)
371 :initial-contents octets))))
373 (defun parse-ipv4-host-address (string)
374 (make-instance 'ipv4-host-address :host-string string))
376 (defmethod format-address ((address ipv4-address))
377 (with-slots (host-bytes) address
378 (format nil "~D.~D.~D.~D"
382 (aref host-bytes 3))))
384 (defparameter *ipv4-localhost* (make-instance 'ipv4-host-address :host-bytes '(127 0 0 1)))
386 (export '(ipv4-address ipv4-host-address make-ipv4-address parse-ipv4-address *ipv4-localhost*))
390 (defclass ipv6-address (inet-address)
391 ((host-bytes :initarg :bytes :type (array (unsigned-byte 8) 16))))
393 (defclass ipv6-host-address (ipv6-address inet-host-address) ())
395 (defun parse-ipv6-string (string)
396 (declare (ignore string))
397 (error "IPv6 parsing not implemented yet"))
399 (defmethod initialize-instance :after ((instance ipv6-address) &key host-bytes host-string host-address)
400 (let ((octets (or host-bytes
402 (check-type host-address ipv6-address)
403 (slot-value host-address 'host-bytes))
404 (when host-string (parse-ipv6-string host-string))
405 '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))
406 (assert (and (typep octets 'sequence)
407 (= (length octets) 16)
408 (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
410 (setf (slot-value instance 'host-bytes)
412 :element-type '(unsigned-byte 8)
413 :initial-contents octets))))
415 (defun parse-ipv6-host-address (string)
416 (make-instance 'ipv6-host-address :host-string string))
418 (defparameter *ipv6-localhost* (make-instance 'ipv6-host-address :host-bytes '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)))
420 (export '(ipv6-address ipv6-host-address parse-ipv6-address *ipv6-localhost*))
424 (defclass inet-port-address (inet-address)
425 ((port :initarg :port :type (unsigned-byte 16))))
427 (defmethod format-address ((address inet-port-address))
428 (with-slots (port) address
429 (format nil "~A:~D" (call-next-method) port)))
431 (defclass tcp-address (inet-port-address) ())
432 (defclass tcp4-address (tcp-address ipv4-address) ())
433 (defclass tcp6-address (tcp-address ipv6-address) ())
435 (defmethod connected-address-p ((address tcp-address)) t)
437 (defun tcp-address-for (host-address port)
438 (check-type port (unsigned-byte 16))
439 (etypecase host-address
440 (ipv4-address (make-instance 'tcp4-address :host-address host-address :port port))
441 (ipv6-address (make-instance 'tcp6-address :host-address host-address :port port))))
443 (export '(tcp-address tcp4-address tcp6-address tcp-address-for))
447 (defclass udp-address (inet-port-address) ())
448 (defclass udp4-address (udp-address ipv4-address) ())
449 (defclass udp6-address (udp-address ipv6-address) ())
451 (defmethod connected-address-p ((address tcp-address)) nil)
453 (defun udp-address-for (host-address port)
454 (check-type port (unsigned-byte 16))
455 (etypecase host-address
456 (ipv4-address (make-instance 'udp4-address :host-address host-address :port port))
457 (ipv6-address (make-instance 'udp6-address :host-address host-address :port port))))
459 (export '(udp-address udp4-address udp6-address udp-address-for))
463 (defclass local-address (address)
464 ((path :type (or pathname nil))))
466 (defmethod initialize-instance :after ((instance local-address) &key path)
467 (setf (slot-value instance 'path) (and path (pathname path))))
469 (defmethod format-address ((address local-address))
470 (let ((path (slot-value address 'path)))
471 (and path (namestring path))))
473 (defclass local-stream-address (local-address) ())
474 (defclass local-seq-address (local-address) ())
475 (defclass local-datagram-address (local-address) ())
477 (defmethod connected-address-p ((address local-stream-address)) t)
478 (defmethod connected-address-p ((address local-seq-address)) t)
479 (defmethod connected-address-p ((address local-datagram-address)) nil)
481 (export '(local-address local-stream-address local-seq-address local-datagram-address))