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 (defvar *parseable-formats* '())
14 (defclass address () ())
16 (defclass host-address (address) ())
18 (defclass inet-address (address) ())
20 (defclass inet-host-address (inet-address host-address) ())
22 (defgeneric format-address (address))
23 (defgeneric connect-to-address (target &key local))
24 (defgeneric bind-to-address (address))
25 (defgeneric close-socket (socket))
26 (defgeneric socket-open-p (socket))
27 (defgeneric socket-local-address (socket))
28 (defgeneric socket-remote-address (socket))
30 (defclass socket () ())
31 (defclass listen-socket (socket) ())
32 (defclass stream-socket (socket) ; Gray stream superclasses are added for implementations that support it.
33 ((mode :initform :byte)
34 (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t)
35 :type (array (unsigned-byte 8)))
36 (byte-read-pos :initform 0 :type integer)
37 (byte-write-pos :initform 0 :type integer)
38 (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)
39 :type (array character))
40 (char-read-pos :initform 0 :type integer)
42 (defclass datagram-socket (socket) ())
44 (defgeneric accept (socket))
45 (defgeneric socket-send (socket data &key start end no-hang))
46 (defgeneric socket-send-to (socket data dest &key start end from no-hang))
47 (defgeneric socket-recv-into (socket buf &key start end no-hang))
48 (defgeneric socket-recv (socket &key no-hang max-len))
50 (defgeneric stream-socket-mode (socket))
51 (defgeneric stream-socket-decode-characters (socket charset))
53 (defmethod socket-recv ((socket socket) &key no-hang (max-len 65536))
54 (let ((buf (make-array (list max-len) :element-type '(unsigned-byte 8))))
55 (multiple-value-bind (len from to)
56 (socket-recv-into socket buf :no-hang no-hang)
59 (values (subseq buf 0 len) from to)))))
61 (defun resolve-address (address)
65 (dolist (fmt *parseable-formats*)
66 (handler-case (return (funcall (cdr fmt) address))
70 (defun define-parseable-address (name fun &optional (order '(:last)))
71 (if (symbolp order) (setf order (list order)))
72 (let ((newlist (remove-if #'(lambda (o) (eq (car o) name)) *parseable-formats*)))
73 (setf *parseable-formats*
76 (cons (cons name fun) newlist))
78 (append newlist `((,name . ,fun))))))))
80 (defmethod print-object ((address address) stream)
82 (format stream "#<~S ~A>" (class-name (class-of address)) (format-address address))
83 (princ (format-address address) stream))
86 (export '(address host-address inet-address inet-host-address
87 format-address resolve-address
88 connect-to-address bind-to-address close-socket
89 socket-local-address socket-remote-address
90 accept socket-send socket-send-to socket-recv-into socket-recv))
92 (defmethod connect-to-address ((target string) &key local)
93 (connect-to-address (resolve-address target) :local local))
95 (defmethod bind-to-address ((address string))
96 (bind-to-address (resolve-address address)))
98 (defmethod stream-socket-mode ((socket stream-socket))
99 (slot-value socket 'mode))
101 (defmethod stream-socket-decode-characters ((socket stream-socket) charset)
102 (unless (eq (stream-socket-mode socket) :byte)
103 (simple-socket-error socket "~S is already in character-decoding mode." socket))
104 (setf (slot-value socket 'encoder) (charcode:make-encoder charset)
105 (slot-value socket 'decoder) (charcode:make-decoder charset)
106 (slot-value socket 'mode) :character))
110 (defmacro with-open-socket ((var socket) &body body)
112 `(let* ((,sk ,socket)
114 (unwind-protect (locally ,@body)
115 (close-socket ,sk)))))
117 (defmacro with-connection ((var target &key local charset) &body body)
118 `(with-open-socket (,var (connect-to-address ,target :local ,local))
119 ,@(when charset (list `(stream-socket-decode-characters ,var ,charset)))
122 (defmacro with-bound-socket ((var address) &body body)
123 `(with-open-socket (,var (bind-to-address ,address))
126 (export '(with-open-socket with-connection with-bound-socket))
128 ;;; Common condition types
130 (define-condition socket-condition (condition)
131 ((socket :initarg :socket :type socket)))
133 (define-condition address-busy (error)
134 ((address :initarg :address :type address))
135 (:report (lambda (c s)
136 (format s "The address ~A is busy." (format-address (slot-value c 'address))))))
138 (define-condition connection-refused (error)
139 ((address :initarg :address :type address))
140 (:report (lambda (c s)
141 (format s "Connection to ~A was refused by the remote host." (format-address (slot-value c 'address))))))
143 (define-condition socket-closed (error socket-condition) ()
144 (:report (lambda (c s)
145 (format s "The socket ~S is closed." (slot-value c 'socket)))))
147 (define-condition socket-disconnected (socket-closed) ()
148 (:report (lambda (c s)
149 (format s "The socket ~S has been closed from the other side." (slot-value c 'socket)))))
151 (define-condition simple-socket-error (simple-error socket-condition) ())
153 (defun simple-socket-error (socket format &rest args)
154 (error 'simple-socket-error :socket socket :format-control format :format-arguments args))
156 ;;; Gray stream implementation for stream sockets
158 (define-condition stream-mode-error (socket-condition stream-error error)
159 ((expected-mode :initarg :expected-mode))
160 (:report (lambda (c s)
161 (with-slots (expected-mode socket) c
162 (format s "Tried to use ~S in ~A mode, but it is in ~A mode." socket expected-mode (stream-socket-mode socket))))))
164 (defun gray-stream-element-type (socket)
165 (declare (type stream-socket socket))
166 (ecase (slot-value socket 'mode)
167 ((:byte) '(unsigned-byte 8))
168 ((:character) 'character)))
170 (defun gray-open-stream-p (socket)
171 (declare (type stream-socket socket))
172 (socket-open-p socket))
174 (defun fill-byte-buffer (socket bytes &optional no-hang)
175 (declare (type stream-socket socket)
177 (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
178 (loop (unless (< (- byte-write-pos byte-read-pos) bytes) (return t))
179 (when (< (- (length byte-buffer) byte-read-pos) bytes)
180 (adjust-array byte-buffer (list (+ byte-read-pos bytes 128))))
181 (let ((recv-len (socket-recv-into socket byte-buffer :start byte-write-pos :no-hang no-hang)))
182 (cond ((null recv-len)
184 (error "~S returned NIL even when called blocking." 'socket-recv-into))
188 (incf byte-write-pos recv-len)))))
190 (defun trim-byte-buffer (socket)
191 (declare (type stream-socket socket))
192 (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
193 (replace byte-buffer byte-buffer :start2 byte-read-pos :end2 byte-write-pos)
194 (decf byte-write-pos byte-read-pos)
195 (setf byte-read-pos 0)
196 (when (> (length byte-buffer) (* byte-write-pos 2))
197 (adjust-array byte-buffer (list byte-write-pos)))))
199 (defun gray-stream-read-byte (socket)
200 (declare (type stream-socket socket))
201 (unless (fill-byte-buffer socket 1)
202 (return-from gray-stream-read-byte :eof))
203 (unless (eq (stream-socket-mode socket) :byte)
204 (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte))
205 (with-slots (byte-buffer byte-read-pos) socket
206 (prog1 (aref byte-buffer byte-read-pos)
207 (when (> (incf byte-read-pos) 128)
208 (trim-byte-buffer socket)))))
210 (defun gray-stream-write-byte (socket byte)
211 (declare (type stream-socket socket))
212 (unless (eq (stream-socket-mode socket) :byte)
213 (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte))
214 (let ((buf (make-array '(1) :element-type '(unsigned-byte 8) :initial-element byte)))
215 (loop (when (> (socket-send socket buf) 0)
218 (defun fill-char-buffer (socket chars &optional no-hang)
219 (declare (type stream-socket socket))
220 (unless (eq (stream-socket-mode socket) :character)
221 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
222 (with-slots (decoder byte-buffer byte-read-pos byte-write-pos char-buffer char-read-pos) socket
223 (loop (unless (< (- (length char-buffer) char-read-pos) chars) (return t))
224 (case (fill-byte-buffer socket chars no-hang)
226 ((:wait) (return :wait)))
227 (funcall decoder byte-buffer char-buffer :start byte-read-pos :end byte-write-pos)
228 (setf byte-read-pos 0
231 (defun trim-char-buffer (socket)
232 (declare (type stream-socket socket))
233 (with-slots (char-buffer char-read-pos) socket
234 (replace char-buffer char-buffer :start2 char-read-pos)
235 (decf (fill-pointer char-buffer) char-read-pos)
236 (setf char-read-pos 0)))
238 (defun gray-stream-read-char (socket)
239 (declare (type stream-socket socket))
240 (unless (eq (stream-socket-mode socket) :character)
241 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
242 (unless (fill-char-buffer socket 1)
243 (return-from gray-stream-read-char :eof))
244 (with-slots (char-buffer char-read-pos) socket
245 (prog1 (aref char-buffer char-read-pos)
246 (when (>= (incf char-read-pos) 64)
247 (trim-char-buffer socket)))))
249 (defun gray-stream-unread-char (socket char)
250 (declare (type stream-socket socket))
251 (unless (eq (stream-socket-mode socket) :character)
252 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
253 (with-slots (char-buffer char-read-pos) socket
254 (when (= char-read-pos 0)
255 (let ((len (length char-buffer)))
256 (when (< (array-dimension char-buffer 0) (+ len 16))
257 (adjust-array char-buffer (list (setf (fill-pointer char-buffer) (+ len 16)))))
258 (replace char-buffer char-buffer :start1 16 :end2 len)))
259 (setf (aref char-buffer (decf char-read-pos)) char)
262 (defun gray-stream-read-char-no-hang (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 (case (fill-char-buffer socket 1)
267 ((nil) (return-from gray-stream-read-char-no-hang :eof))
268 ((:wait) (return-from gray-stream-read-char-no-hang nil)))
269 (with-slots (char-buffer char-read-pos) socket
270 (prog1 (aref char-buffer char-read-pos)
271 (when (>= (incf char-read-pos) 64)
272 (trim-char-buffer socket)))))
274 (defun gray-stream-peek-char (socket)
275 (declare (type stream-socket socket))
276 (unless (eq (stream-socket-mode socket) :character)
277 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
278 (unless (fill-char-buffer socket 1)
279 (return-from gray-stream-peek-char :eof))
280 (with-slots (char-buffer char-read-pos) socket
281 (aref char-buffer char-read-pos)))
283 (defun gray-stream-listen (socket)
284 (declare (type stream-socket socket))
285 (unless (eq (stream-socket-mode socket) :character)
286 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
287 (case (fill-char-buffer socket 1)
288 ((nil :wait) (return-from gray-stream-listen nil)))
289 (with-slots (char-buffer char-read-pos) socket
290 (aref char-buffer char-read-pos)))
292 (defun gray-stream-write-char (socket char)
293 (declare (type stream-socket socket))
294 (unless (eq (stream-socket-mode socket) :character)
295 (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
296 (with-slots (encoder) socket
297 (let ((seq (make-array '(1) :element-type 'character :initial-element char))
298 (outbuf (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
299 (funcall encoder seq outbuf)
301 (loop (unless (< pos (length outbuf)) (return))
302 (incf pos (socket-send socket outbuf :start pos)))))))
304 (defun gray-stream-read-sequence (socket seq start end)
305 (declare (type stream-socket socket))
306 (ecase (stream-socket-mode socket)
308 (fill-byte-buffer socket (- end start))
309 (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
310 (replace seq byte-buffer :start1 start :start2 byte-read-pos :end1 end :end2 byte-write-pos)
311 (let ((len (min (- end start) (- byte-write-pos byte-read-pos))))
312 (when (> (incf byte-read-pos len) 128)
313 (trim-byte-buffer socket))
316 (fill-char-buffer socket (- end start))
317 (with-slots (char-buffer char-read-pos) socket
318 (replace seq char-buffer :start1 start :start2 char-read-pos :end1 end :end2 (length char-buffer))
319 (let ((len (min (- end start) (- (length char-buffer) char-read-pos))))
320 (when (> (incf char-read-pos len) 128)
321 (trim-char-buffer socket))
324 (defmethod gray-stream-write-sequence (socket seq start end)
325 (declare (type stream-socket socket))
326 (let ((end (or end (length seq))))
327 (ecase (stream-socket-mode socket)
329 (loop (unless (< start end) (return seq))
330 (incf start (socket-send socket seq :start start :end end))))
332 (with-slots (encoder) socket
333 (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))
335 (funcall encoder seq outbuf :start start :end end)
336 (loop (unless (< pos (length outbuf)) (return seq))
337 (incf pos (socket-send socket outbuf :start pos)))))))))
341 (defclass ipv4-address (inet-host-address)
342 ((bytes :initarg :bytes :type (array (unsigned-byte 8) 4))))
344 (defun make-ipv4-address (o1 o2 o3 o4)
345 (make-instance 'ipv4-address :bytes (make-array '(4)
346 :element-type '(unsigned-byte 8)
347 :initial-contents (list o1 o2 o3 o4))))
349 (defun parse-ipv4-address (string)
352 (string (concatenate 'string string "."))
353 (buf (make-array '(4) :element-type '(unsigned-byte 8))))
354 (dotimes (i (length string))
355 (let ((ch (elt string i)))
358 (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i)))
359 (if (and n (<= 0 n 255))
361 (error "IPv4 dottet-quad numbers must be octets"))))
364 (error "Too many octets in IPv4 address")))
367 (t (error "Invalid character ~S in IPv4 address" ch)))))
369 (error "Too few octets in IPv4 address")
370 (make-instance 'ipv4-address :bytes buf))))
372 (define-parseable-address 'ipv4-address #'parse-ipv4-address :first)
374 (defmethod format-address ((address ipv4-address))
375 (with-slots (bytes) address
376 (format nil "~D.~D.~D.~D"
382 (export '(ipv4-address make-ipv4-address parse-ipv4-address))
386 (defclass ipv6-address (inet-host-address)
387 ((bytes :initarg :bytes :type (array (unsigned-byte 8) 16))))
389 (defun parse-ipv6-address (string)
390 (declare (ignore string))
391 (error "IPv6 parsing not implemented yet"))
393 (define-parseable-address 'ipv6-address #'parse-ipv6-address :first)
395 (export '(ipv6-address parse-ipv6-address))
399 (defclass inet-port-address (inet-address)
400 ((host :initarg :host :type (or null inet-host-address))
401 (port :initarg :port :type (unsigned-byte 16))))
403 (defclass tcp-address (inet-port-address) ())
405 (defmethod format-address ((address tcp-address))
406 (with-slots (host port) address
407 (format nil "~A:~D" (if host (format-address host) "*") port)))
409 (defun inet-resolve-colon-port (string)
410 (let ((colon (position #\: string)))
412 (error "No colon in TCP address"))
413 (if (find #\: string :start (1+ colon))
414 (error "More than one colon in TCP address"))
415 (let ((port (parse-integer (subseq string (1+ colon))))
416 (host (let ((host-part (subseq string 0 colon)))
417 (if (equal host-part "*")
419 (resolve-address host-part)))))
420 (if (not (typep host '(or null inet-host-address)))
421 (error "Must have an internet address for TCP connections"))
422 (values host port))))
424 (defun resolve-tcp-colon-port (address)
425 (multiple-value-bind (host port)
426 (inet-resolve-colon-port address)
427 (make-instance 'tcp-address :host host :port port)))
429 (define-parseable-address 'tcp-service #'resolve-tcp-colon-port)
431 (export '(tcp-address resolve-tcp-colon-port))
435 (defclass udp-address (inet-port-address) ())
437 (defmethod format-address ((address udp-address))
438 (with-slots (host port) address
439 (format nil "~A:~D" (if host (format-address host) "*") port)))
441 (defun resolve-udp-colon-port (address)
442 (multiple-value-bind (host port)
443 (inet-resolve-colon-port address)
444 (make-instance 'udp-address :host host :port port)))
446 (export '(udp-address resolve-udp-colon-port))
450 (defclass local-address (address)
451 ((path :initarg :path :type pathname)))
453 (defmethod format-address ((address local-address))
454 (namestring (slot-value address 'path)))
456 (defclass local-stream-address (local-address) ())
457 (defclass local-seq-address (local-address) ())
458 (defclass local-datagram-address (local-address) ())
460 (defun make-local-address (pathspec &optional (type :stream))
461 (make-instance (ecase type
462 ((:stream) 'local-stream-address)
463 ((:seq) 'local-seq-address)
464 ((:datagram) 'local-datagram-address))
465 :path (pathname pathspec)))
467 (export '(local-address make-local-address))