00ae20d4aa7b296af7bfd98b0e9a5be2c7fbd6c6
[lisp-utils.git] / common-net.lisp
1 ;;;; COMMON-NET -- Abstract networking library
2
3 (eval-when (:compile-toplevel :load-toplevel :execute)
4   (unless (find-package :common-net)
5     (defpackage :common-net
6       (:nicknames :net)
7       (:use :cl))))
8 (in-package :common-net)
9
10 ;;; General declarations
11
12 (defclass address () ())
13 (defclass host-address (address) ())
14
15 (defclass inet-address (address) ())
16 (defclass inet-host-address (inet-address host-address) ())
17
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))
26
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)
38    encoder decoder))
39 (defclass datagram-socket (socket) ())
40
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))
46
47 (defgeneric stream-socket-mode (socket))
48 (defgeneric stream-socket-decode-characters (socket charset))
49
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)
54       (if (null len)
55           (values nil nil nil)
56           (values (subseq buf 0 len) from to)))))
57
58 (defmethod print-object ((address address) stream)
59   (if *print-escape*
60       (format stream "#<~S ~A>" (class-name (class-of address)) (format-address address))
61       (princ (format-address address) stream))
62   address)
63
64 (defmethod connected-address-p ((address inet-host-address))
65   nil)
66
67 (export '(address host-address inet-address inet-host-address
68           format-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))
72
73 (defmethod stream-socket-mode ((socket stream-socket))
74   (slot-value socket 'mode))
75
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))
82
83 ;;; Utility macros
84
85 (defmacro with-open-socket ((var socket) &body body)
86   (let ((sk (gensym)))
87     `(let* ((,sk ,socket)
88             (,var ,sk))
89        (unwind-protect (locally ,@body)
90          (close-socket ,sk)))))
91
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)))
95      ,@body))
96
97 (defmacro with-bound-socket ((var address) &body body)
98   `(with-open-socket (,var (bind-to-address ,address))
99      ,@body))
100
101 (export '(with-open-socket with-connection with-bound-socket))
102
103 ;;; Common condition types
104
105 (define-condition socket-condition (condition)
106   ((socket :initarg :socket :type socket)))
107
108 (define-condition network-error (error) ())
109
110 (define-condition socket-error (socket-condition network-error) ())
111
112 (define-condition address-busy (network-error)
113   ((address :initarg :address :type address))
114   (:report (lambda (c s)
115              (format s "The address ~A is busy." (format-address (slot-value c 'address))))))
116
117 (define-condition connection-refused (network-error)
118   ((address :initarg :address :type address))
119   (:report (lambda (c s)
120              (format s "Connection to ~A was refused by the remote host." (format-address (slot-value c 'address))))))
121
122 (define-condition socket-closed (socket-error) ()
123   (:report (lambda (c s)
124              (format s "The socket ~S is closed." (slot-value c 'socket)))))
125
126 (define-condition socket-disconnected (socket-closed) ()
127   (:report (lambda (c s)
128              (format s "The socket ~S has been closed from the other side." (slot-value c 'socket)))))
129
130 (define-condition simple-socket-error (simple-error socket-error) ())
131
132 (defun simple-socket-error (socket format &rest args)
133   (error 'simple-socket-error :socket socket :format-control format :format-arguments args))
134
135 (export '(socket-condition network-error socket-error
136           address-busy connection-refused
137           socket-closed socket-disconnected simple-socket-error))
138
139 ;;; Gray stream implementation for stream sockets
140
141 (define-condition stream-mode-error (socket-error stream-error)
142   ((expected-mode :initarg :expected-mode))
143   (:report (lambda (c s)
144              (with-slots (expected-mode socket) c
145                (format s "Tried to use ~S in ~A mode, but it is in ~A mode." socket expected-mode (stream-socket-mode socket))))))
146
147 (defun gray-stream-element-type (socket)
148   (declare (type stream-socket socket))
149   (ecase (slot-value socket 'mode)
150     ((:byte) '(unsigned-byte 8))
151     ((:character) 'character)))
152
153 (defun gray-open-stream-p (socket)
154   (declare (type stream-socket socket))
155   (socket-open-p socket))
156
157 (defun fill-byte-buffer (socket bytes &optional no-hang)
158   (declare (type stream-socket socket)
159            (type fixnum bytes))
160   (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
161     (loop (unless (< (- byte-write-pos byte-read-pos) bytes) (return t))
162        (when (< (- (length byte-buffer) byte-read-pos) bytes)
163          (adjust-array byte-buffer (list (+ byte-read-pos bytes 128))))
164        (let ((recv-len (socket-recv-into socket byte-buffer :start byte-write-pos :no-hang no-hang)))
165          (cond ((null recv-len)
166                 (unless no-hang
167                   (error "~S returned NIL even when called blocking." 'socket-recv-into))
168                 (return :wait))
169                ((= recv-len 0)
170                 (return nil)))
171          (incf byte-write-pos recv-len)))))
172
173 (defun trim-byte-buffer (socket)
174   (declare (type stream-socket socket))
175   (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
176     (replace byte-buffer byte-buffer :start2 byte-read-pos :end2 byte-write-pos)
177     (decf byte-write-pos byte-read-pos)
178     (setf byte-read-pos 0)
179     (when (> (length byte-buffer) (* byte-write-pos 2))
180       (adjust-array byte-buffer (list byte-write-pos)))))
181
182 (defun gray-stream-read-byte (socket)
183   (declare (type stream-socket socket))
184   (unless (fill-byte-buffer socket 1)
185     (return-from gray-stream-read-byte :eof))
186   (unless (eq (stream-socket-mode socket) :byte)
187     (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte))
188   (with-slots (byte-buffer byte-read-pos) socket
189     (prog1 (aref byte-buffer byte-read-pos)
190       (when (> (incf byte-read-pos) 128)
191         (trim-byte-buffer socket)))))
192
193 (defun gray-stream-write-byte (socket byte)
194   (declare (type stream-socket socket))
195   (unless (eq (stream-socket-mode socket) :byte)
196     (error 'stream-mode-error :stream socket :socket socket :expected-mode :byte))
197   (let ((buf (make-array '(1) :element-type '(unsigned-byte 8) :initial-element byte)))
198     (loop (when (> (socket-send socket buf) 0)
199             (return)))))
200
201 (defun fill-char-buffer (socket chars &optional no-hang)
202   (declare (type stream-socket socket))
203   (unless (eq (stream-socket-mode socket) :character)
204     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
205   (with-slots (decoder byte-buffer byte-read-pos byte-write-pos char-buffer char-read-pos) socket
206     (loop (unless (< (- (length char-buffer) char-read-pos) chars) (return t))
207        (case (fill-byte-buffer socket chars no-hang)
208          ((nil) (return nil))
209          ((:wait) (return :wait)))
210        (funcall decoder byte-buffer char-buffer :start byte-read-pos :end byte-write-pos)
211        (setf byte-read-pos 0
212              byte-write-pos 0))))
213
214 (defun trim-char-buffer (socket)
215   (declare (type stream-socket socket))
216   (with-slots (char-buffer char-read-pos) socket
217     (replace char-buffer char-buffer :start2 char-read-pos)
218     (decf (fill-pointer char-buffer) char-read-pos)
219     (setf char-read-pos 0)))
220
221 (defun gray-stream-read-char (socket)
222   (declare (type stream-socket socket))
223   (unless (eq (stream-socket-mode socket) :character)
224     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
225   (unless (fill-char-buffer socket 1)
226     (return-from gray-stream-read-char :eof))
227   (with-slots (char-buffer char-read-pos) socket
228     (prog1 (aref char-buffer char-read-pos)
229       (when (>= (incf char-read-pos) 64)
230         (trim-char-buffer socket)))))
231
232 (defun gray-stream-unread-char (socket char)
233   (declare (type stream-socket socket))
234   (unless (eq (stream-socket-mode socket) :character)
235     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
236   (with-slots (char-buffer char-read-pos) socket
237     (when (= char-read-pos 0)
238       (let ((len (length char-buffer)))
239         (when (< (array-dimension char-buffer 0) (+ len 16))
240           (adjust-array char-buffer (list (setf (fill-pointer char-buffer) (+ len 16)))))
241         (replace char-buffer char-buffer :start1 16 :end2 len)))
242     (setf (aref char-buffer (decf char-read-pos)) char)
243     nil))
244
245 (defun gray-stream-read-char-no-hang (socket)
246   (declare (type stream-socket socket))
247   (unless (eq (stream-socket-mode socket) :character)
248     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
249   (case (fill-char-buffer socket 1)
250     ((nil) (return-from gray-stream-read-char-no-hang :eof))
251     ((:wait) (return-from gray-stream-read-char-no-hang nil)))
252   (with-slots (char-buffer char-read-pos) socket
253     (prog1 (aref char-buffer char-read-pos)
254       (when (>= (incf char-read-pos) 64)
255         (trim-char-buffer socket)))))
256
257 (defun gray-stream-peek-char (socket)
258   (declare (type stream-socket socket))
259   (unless (eq (stream-socket-mode socket) :character)
260     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
261   (unless (fill-char-buffer socket 1)
262     (return-from gray-stream-peek-char :eof))
263   (with-slots (char-buffer char-read-pos) socket
264     (aref char-buffer char-read-pos)))
265
266 (defun gray-stream-listen (socket)
267   (declare (type stream-socket socket))
268   (unless (eq (stream-socket-mode socket) :character)
269     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
270   (case (fill-char-buffer socket 1)
271     ((nil :wait) (return-from gray-stream-listen nil)))
272   (with-slots (char-buffer char-read-pos) socket
273     (aref char-buffer char-read-pos)))
274
275 (defun gray-stream-write-char (socket char)
276   (declare (type stream-socket socket))
277   (unless (eq (stream-socket-mode socket) :character)
278     (error 'stream-mode-error :stream socket :socket socket :expected-mode :character))
279   (with-slots (encoder) socket
280     (let ((seq (make-array '(1) :element-type 'character :initial-element char))
281           (outbuf (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
282       (funcall encoder seq outbuf)
283       (let ((pos 0))
284         (loop (unless (< pos (length outbuf)) (return))
285            (incf pos (socket-send socket outbuf :start pos)))))))
286
287 (defun gray-stream-read-sequence (socket seq start end)
288   (declare (type stream-socket socket))
289   (ecase (stream-socket-mode socket)
290     ((:byte)
291      (fill-byte-buffer socket (- end start))
292      (with-slots (byte-buffer byte-read-pos byte-write-pos) socket
293        (replace seq byte-buffer :start1 start :start2 byte-read-pos :end1 end :end2 byte-write-pos)
294        (let ((len (min (- end start) (- byte-write-pos byte-read-pos))))
295          (when (> (incf byte-read-pos len) 128)
296            (trim-byte-buffer socket))
297          (+ start len))))
298     ((:character)
299      (fill-char-buffer socket (- end start))
300      (with-slots (char-buffer char-read-pos) socket
301        (replace seq char-buffer :start1 start :start2 char-read-pos :end1 end :end2 (length char-buffer))
302        (let ((len (min (- end start) (- (length char-buffer) char-read-pos))))
303          (when (> (incf char-read-pos len) 128)
304            (trim-char-buffer socket))
305          (+ start len))))))
306
307 (defmethod gray-stream-write-sequence (socket seq start end)
308   (declare (type stream-socket socket))
309   (let ((end (or end (length seq))))
310     (ecase (stream-socket-mode socket)
311       ((:byte)
312        (loop (unless (< start end) (return seq))
313           (incf start (socket-send socket seq :start start :end end))))
314       ((:character)
315        (with-slots (encoder) socket
316          (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))
317                (pos 0))
318            (funcall encoder seq outbuf :start start :end end)
319            (loop (unless (< pos (length outbuf)) (return seq))
320               (incf pos (socket-send socket outbuf :start pos)))))))))
321
322 ;;; IPv4 addresses
323
324 (defclass ipv4-address (inet-address)
325   ((host-bytes :type (array (unsigned-byte 8) 4))))
326
327 (defclass ipv4-host-address (ipv4-address inet-host-address) ())
328
329 (defun parse-dotted-quad (string)
330   (let ((o 0)
331         (start 0)
332         (string (concatenate 'string string "."))
333         (buf (make-array '(4) :element-type '(unsigned-byte 8))))
334     (dotimes (i (length string))
335       (let ((ch (elt string i)))
336         (cond ((eql ch #\.)
337                (if (< o 4)
338                    (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i)))
339                                                (if (and n (<= 0 n 255))
340                                                    n
341                                                    (error "IPv4 dotted-quad numbers must be octets"))))
342                           (setf start (1+ i))
343                           (incf o))
344                    (error "Too many octets in IPv4 address")))
345               ((char<= #\0 ch #\9)
346                nil)
347               (t (error "Invalid character ~S in IPv4 address" ch)))))
348     (if (< o 4)
349         (error "Too few octets in IPv4 address")
350         buf)))
351
352 (defmethod initialize-instance :after ((instance ipv4-address) &key host-bytes host-string)
353   (let ((octets (or host-bytes
354                     (when host-string (parse-dotted-quad host-string))
355                     '(0 0 0 0))))
356     (assert (and (typep octets 'sequence)
357                  (= (length octets) 4)
358                  (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
359             (octets))
360     (setf (slot-value instance 'host-bytes)
361           (make-array '(4)
362                       :element-type '(unsigned-byte 8)
363                       :initial-contents octets))))
364
365 (defun parse-ipv4-host-address (string)
366   (make-instance 'ipv4-host-address :host-string string))
367
368 (defmethod format-address ((address ipv4-address))
369   (with-slots (host-bytes) address
370     (format nil "~D.~D.~D.~D"
371             (aref host-bytes 0)
372             (aref host-bytes 1)
373             (aref host-bytes 2)
374             (aref host-bytes 3))))
375
376 (export '(ipv4-address make-ipv4-address parse-ipv4-address))
377
378 ;;; IPv6 addresses
379
380 (defclass ipv6-address (inet-address)
381   ((host-bytes :initarg :bytes :type (array (unsigned-byte 8) 16))))
382
383 (defclass ipv6-host-address (ipv6-address inet-host-address) ())
384
385 (defun parse-ipv6-string (string)
386   (declare (ignore string))
387   (error "IPv6 parsing not implemented yet"))
388
389 (defmethod initialize-instance :after ((instance ipv6-address) &key host-bytes host-string)
390   (let ((octets (or host-bytes
391                     (when host-string (parse-ipv6-string host-string))
392                     '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))
393     (assert (and (typep octets 'sequence)
394                  (= (length octets) 16)
395                  (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
396             (octets))
397     (setf (slot-value instance 'host-bytes)
398           (make-array '(16)
399                       :element-type '(unsigned-byte 8)
400                       :initial-contents octets))))
401
402 (defun parse-ipv6-host-address (string)
403   (make-instance 'ipv6-host-address :host-string string))
404
405 (export '(ipv6-address parse-ipv6-address))
406
407 ;;; TCP code
408
409 (defclass inet-port-address (inet-address)
410   ((port :initarg :port :type (unsigned-byte 16))))
411
412 (defmethod format-address ((address inet-port-address))
413   (with-slots (port) address
414     (format nil "~A:~D" (call-next-method) port)))
415
416 (defclass tcp-address (inet-port-address) ())
417 (defclass tcp4-address (tcp-address ipv4-address) ())
418 (defclass tcp6-address (tcp-address ipv6-address) ())
419
420 (defmethod connected-address-p ((address tcp-address)) t)
421
422 (export '(tcp-address tcp4-address tcp6-address))
423
424 ;;; UDP code
425
426 (defclass udp-address (inet-port-address) ())
427 (defclass udp4-address (udp-address ipv4-address) ())
428 (defclass udp6-address (udp-address ipv6-address) ())
429
430 (defmethod connected-address-p ((address tcp-address)) nil)
431
432 (export '(udp-address udp4-address udp6-address))
433
434 ;;; Unix sockets
435
436 (defclass local-address (address)
437   ((path :type pathname)))
438
439 (defmethod initialize-instance :after ((instance local-address) &key path)
440   (setf (slot-value instance 'path) (pathname path)))
441
442 (defmethod format-address ((address local-address))
443   (namestring (slot-value address 'path)))
444
445 (defclass local-stream-address (local-address) ())
446 (defclass local-seq-address (local-address) ())
447 (defclass local-datagram-address (local-address) ())
448
449 (defmethod connected-address-p ((address local-stream-address)) t)
450 (defmethod connected-address-p ((address local-seq-address)) t)
451 (defmethod connected-address-p ((address local-datagram-address)) nil)
452
453 (export '(local-address local-stream-address local-seq-address local-datagram-address))