Fixed up Unix sockets a bit.
[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 simple-network-error (network-error simple-error) ())
111
112 (defun simple-network-error (format &rest args)
113   (error 'simple-network-error :format-control format :format-arguments args))
114
115 (define-condition socket-error (socket-condition network-error) ())
116
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))))))
121
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))))))
126
127 (define-condition socket-closed (socket-error) ()
128   (:report (lambda (c s)
129              (format s "The socket ~S is closed." (slot-value c 'socket)))))
130
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)))))
134
135 (define-condition simple-socket-error (simple-error socket-error) ())
136
137 (defun simple-socket-error (socket format &rest args)
138   (error 'simple-socket-error :socket socket :format-control format :format-arguments args))
139
140 (export '(socket-condition network-error socket-error
141           address-busy connection-refused
142           socket-closed socket-disconnected simple-socket-error))
143
144 ;;; Gray stream implementation for stream sockets
145
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))))))
151
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)))
157
158 (defun gray-open-stream-p (socket)
159   (declare (type stream-socket socket))
160   (socket-open-p socket))
161
162 (defun fill-byte-buffer (socket bytes &optional no-hang)
163   (declare (type stream-socket socket)
164            (type fixnum bytes))
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)
171                 (unless no-hang
172                   (error "~S returned NIL even when called blocking." 'socket-recv-into))
173                 (return :wait))
174                ((= recv-len 0)
175                 (return nil)))
176          (incf byte-write-pos recv-len)))))
177
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)))))
186
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)))))
197
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)
204             (return)))))
205
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)
213          ((nil) (return nil))
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
217              byte-write-pos 0))))
218
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)))
225
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)))))
236
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)
248     nil))
249
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)))))
261
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)))
270
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)))
279
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)
288       (let ((pos 0))
289         (loop (unless (< pos (length outbuf)) (return))
290            (incf pos (socket-send socket outbuf :start pos)))))))
291
292 (defun gray-stream-read-sequence (socket seq start end)
293   (declare (type stream-socket socket))
294   (ecase (stream-socket-mode socket)
295     ((:byte)
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))
302          (+ start len))))
303     ((:character)
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))
310          (+ start len))))))
311
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)
316       ((:byte)
317        (loop (unless (< start end) (return seq))
318           (incf start (socket-send socket seq :start start :end end))))
319       ((:character)
320        (with-slots (encoder) socket
321          (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))
322                (pos 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)))))))))
326
327 ;;; IPv4 addresses
328
329 (defclass ipv4-address (inet-address)
330   ((host-bytes :type (array (unsigned-byte 8) 4))))
331
332 (defclass ipv4-host-address (ipv4-address inet-host-address) ())
333
334 (defun parse-dotted-quad (string)
335   (let ((o 0)
336         (start 0)
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)))
341         (cond ((eql ch #\.)
342                (if (< o 4)
343                    (progn (setf (aref buf o) (let ((n (parse-integer string :start start :end i)))
344                                                (if (and n (<= 0 n 255))
345                                                    n
346                                                    (error "IPv4 dotted-quad numbers must be octets"))))
347                           (setf start (1+ i))
348                           (incf o))
349                    (error "Too many octets in IPv4 address")))
350               ((char<= #\0 ch #\9)
351                nil)
352               (t (error "Invalid character ~S in IPv4 address" ch)))))
353     (if (< o 4)
354         (error "Too few octets in IPv4 address")
355         buf)))
356
357 (defmethod initialize-instance :after ((instance ipv4-address) &key host-bytes host-string host-address)
358   (let ((octets (or host-bytes
359                     (when host-address
360                       (check-type host-address ipv4-address)
361                       (slot-value host-address 'host-bytes))
362                     (when host-string (parse-dotted-quad host-string))
363                     '(0 0 0 0))))
364     (assert (and (typep octets 'sequence)
365                  (= (length octets) 4)
366                  (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
367             (octets))
368     (setf (slot-value instance 'host-bytes)
369           (make-array '(4)
370                       :element-type '(unsigned-byte 8)
371                       :initial-contents octets))))
372
373 (defun parse-ipv4-host-address (string)
374   (make-instance 'ipv4-host-address :host-string string))
375
376 (defmethod format-address ((address ipv4-address))
377   (with-slots (host-bytes) address
378     (format nil "~D.~D.~D.~D"
379             (aref host-bytes 0)
380             (aref host-bytes 1)
381             (aref host-bytes 2)
382             (aref host-bytes 3))))
383
384 (defparameter *ipv4-localhost* (make-instance 'ipv4-host-address :host-bytes '(127 0 0 1)))
385
386 (export '(ipv4-address ipv4-host-address make-ipv4-address parse-ipv4-address *ipv4-localhost*))
387
388 ;;; IPv6 addresses
389
390 (defclass ipv6-address (inet-address)
391   ((host-bytes :initarg :bytes :type (array (unsigned-byte 8) 16))))
392
393 (defclass ipv6-host-address (ipv6-address inet-host-address) ())
394
395 (defun parse-ipv6-string (string)
396   (declare (ignore string))
397   (error "IPv6 parsing not implemented yet"))
398
399 (defmethod initialize-instance :after ((instance ipv6-address) &key host-bytes host-string host-address)
400   (let ((octets (or host-bytes
401                     (when host-address
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))
409             (octets))
410     (setf (slot-value instance 'host-bytes)
411           (make-array '(16)
412                       :element-type '(unsigned-byte 8)
413                       :initial-contents octets))))
414
415 (defun parse-ipv6-host-address (string)
416   (make-instance 'ipv6-host-address :host-string string))
417
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)))
419
420 (export '(ipv6-address ipv6-host-address parse-ipv6-address *ipv6-localhost*))
421
422 ;;; TCP code
423
424 (defclass inet-port-address (inet-address)
425   ((port :initarg :port :type (unsigned-byte 16))))
426
427 (defmethod format-address ((address inet-port-address))
428   (with-slots (port) address
429     (format nil "~A:~D" (call-next-method) port)))
430
431 (defclass tcp-address (inet-port-address) ())
432 (defclass tcp4-address (tcp-address ipv4-address) ())
433 (defclass tcp6-address (tcp-address ipv6-address) ())
434
435 (defmethod connected-address-p ((address tcp-address)) t)
436
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))))
442
443 (export '(tcp-address tcp4-address tcp6-address tcp-address-for))
444
445 ;;; UDP code
446
447 (defclass udp-address (inet-port-address) ())
448 (defclass udp4-address (udp-address ipv4-address) ())
449 (defclass udp6-address (udp-address ipv6-address) ())
450
451 (defmethod connected-address-p ((address tcp-address)) nil)
452
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))))
458
459 (export '(udp-address udp4-address udp6-address udp-address-for))
460
461 ;;; Unix sockets
462
463 (defclass local-address (address)
464   ((path :type (or pathname nil))))
465
466 (defmethod initialize-instance :after ((instance local-address) &key path)
467   (setf (slot-value instance 'path) (and path (pathname path))))
468
469 (defmethod format-address ((address local-address))
470   (let ((path (slot-value address 'path)))
471     (and path (namestring path))))
472
473 (defclass local-stream-address (local-address) ())
474 (defclass local-seq-address (local-address) ())
475 (defclass local-datagram-address (local-address) ())
476
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)
480
481 (export '(local-address local-stream-address local-seq-address local-datagram-address))