Enabled initialization of IP addresses from another host address.
[lisp-utils.git] / common-net.lisp
CommitLineData
dfa6197c
FT
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
dfa6197c 12(defclass address () ())
dfa6197c
FT
13(defclass host-address (address) ())
14
15(defclass inet-address (address) ())
dfa6197c
FT
16(defclass inet-host-address (inet-address host-address) ())
17
18(defgeneric format-address (address))
b5018cad 19(defgeneric connected-address-p (address))
dfa6197c
FT
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
dfa6197c
FT
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
b5018cad
FT
64(defmethod connected-address-p ((address inet-host-address))
65 nil)
66
dfa6197c 67(export '(address host-address inet-address inet-host-address
bdc87fbb 68 format-address
dfa6197c
FT
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
dfa6197c
FT
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
b5018cad
FT
108(define-condition network-error (error) ())
109
110(define-condition socket-error (socket-condition network-error) ())
111
112(define-condition address-busy (network-error)
dfa6197c
FT
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
b5018cad 117(define-condition connection-refused (network-error)
dfa6197c
FT
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
b5018cad 122(define-condition socket-closed (socket-error) ()
dfa6197c
FT
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
b5018cad 130(define-condition simple-socket-error (simple-error socket-error) ())
dfa6197c
FT
131
132(defun simple-socket-error (socket format &rest args)
133 (error 'simple-socket-error :socket socket :format-control format :format-arguments args))
134
b5018cad
FT
135(export '(socket-condition network-error socket-error
136 address-busy connection-refused
137 socket-closed socket-disconnected simple-socket-error))
138
dfa6197c
FT
139;;; Gray stream implementation for stream sockets
140
b5018cad 141(define-condition stream-mode-error (socket-error stream-error)
dfa6197c
FT
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
b5018cad
FT
324(defclass ipv4-address (inet-address)
325 ((host-bytes :type (array (unsigned-byte 8) 4))))
dfa6197c 326
b5018cad 327(defclass ipv4-host-address (ipv4-address inet-host-address) ())
dfa6197c 328
b5018cad 329(defun parse-dotted-quad (string)
dfa6197c
FT
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
b5018cad 341 (error "IPv4 dotted-quad numbers must be octets"))))
dfa6197c
FT
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")
b5018cad
FT
350 buf)))
351
cc4296f0 352(defmethod initialize-instance :after ((instance ipv4-address) &key host-bytes host-string host-address)
b5018cad 353 (let ((octets (or host-bytes
cc4296f0
FT
354 (when host-address
355 (check-type host-address ipv4-address)
356 (slot-value host-address 'host-bytes))
b5018cad
FT
357 (when host-string (parse-dotted-quad host-string))
358 '(0 0 0 0))))
359 (assert (and (typep octets 'sequence)
360 (= (length octets) 4)
361 (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
362 (octets))
363 (setf (slot-value instance 'host-bytes)
364 (make-array '(4)
365 :element-type '(unsigned-byte 8)
366 :initial-contents octets))))
367
368(defun parse-ipv4-host-address (string)
369 (make-instance 'ipv4-host-address :host-string string))
dfa6197c 370
dfa6197c 371(defmethod format-address ((address ipv4-address))
b5018cad 372 (with-slots (host-bytes) address
dfa6197c 373 (format nil "~D.~D.~D.~D"
b5018cad
FT
374 (aref host-bytes 0)
375 (aref host-bytes 1)
376 (aref host-bytes 2)
377 (aref host-bytes 3))))
dfa6197c 378
cc4296f0
FT
379(defparameter *ipv4-localhost* (make-instance 'ipv4-host-address :host-bytes '(127 0 0 1)))
380
381(export '(ipv4-address ipv4-host-address make-ipv4-address parse-ipv4-address *ipv4-localhost*))
dfa6197c
FT
382
383;;; IPv6 addresses
384
b5018cad
FT
385(defclass ipv6-address (inet-address)
386 ((host-bytes :initarg :bytes :type (array (unsigned-byte 8) 16))))
dfa6197c 387
b5018cad
FT
388(defclass ipv6-host-address (ipv6-address inet-host-address) ())
389
390(defun parse-ipv6-string (string)
dfa6197c
FT
391 (declare (ignore string))
392 (error "IPv6 parsing not implemented yet"))
393
cc4296f0 394(defmethod initialize-instance :after ((instance ipv6-address) &key host-bytes host-string host-address)
b5018cad 395 (let ((octets (or host-bytes
cc4296f0
FT
396 (when host-address
397 (check-type host-address ipv6-address)
398 (slot-value host-address 'host-bytes))
b5018cad
FT
399 (when host-string (parse-ipv6-string host-string))
400 '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))
401 (assert (and (typep octets 'sequence)
402 (= (length octets) 16)
403 (every #'(lambda (o) (typep o '(unsigned-byte 8))) octets))
404 (octets))
405 (setf (slot-value instance 'host-bytes)
406 (make-array '(16)
407 :element-type '(unsigned-byte 8)
408 :initial-contents octets))))
409
410(defun parse-ipv6-host-address (string)
411 (make-instance 'ipv6-host-address :host-string string))
412
cc4296f0
FT
413(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)))
414
415(export '(ipv6-address ipv6-host-address parse-ipv6-address *ipv6-localhost*))
dfa6197c
FT
416
417;;; TCP code
418
419(defclass inet-port-address (inet-address)
b5018cad
FT
420 ((port :initarg :port :type (unsigned-byte 16))))
421
422(defmethod format-address ((address inet-port-address))
423 (with-slots (port) address
424 (format nil "~A:~D" (call-next-method) port)))
dfa6197c
FT
425
426(defclass tcp-address (inet-port-address) ())
b5018cad
FT
427(defclass tcp4-address (tcp-address ipv4-address) ())
428(defclass tcp6-address (tcp-address ipv6-address) ())
dfa6197c 429
b5018cad
FT
430(defmethod connected-address-p ((address tcp-address)) t)
431
432(export '(tcp-address tcp4-address tcp6-address))
dfa6197c
FT
433
434;;; UDP code
435
436(defclass udp-address (inet-port-address) ())
b5018cad
FT
437(defclass udp4-address (udp-address ipv4-address) ())
438(defclass udp6-address (udp-address ipv6-address) ())
dfa6197c 439
b5018cad 440(defmethod connected-address-p ((address tcp-address)) nil)
dfa6197c 441
b5018cad 442(export '(udp-address udp4-address udp6-address))
dfa6197c
FT
443
444;;; Unix sockets
445
446(defclass local-address (address)
b5018cad
FT
447 ((path :type pathname)))
448
449(defmethod initialize-instance :after ((instance local-address) &key path)
450 (setf (slot-value instance 'path) (pathname path)))
dfa6197c
FT
451
452(defmethod format-address ((address local-address))
453 (namestring (slot-value address 'path)))
454
455(defclass local-stream-address (local-address) ())
456(defclass local-seq-address (local-address) ())
457(defclass local-datagram-address (local-address) ())
458
b5018cad
FT
459(defmethod connected-address-p ((address local-stream-address)) t)
460(defmethod connected-address-p ((address local-seq-address)) t)
461(defmethod connected-address-p ((address local-datagram-address)) nil)
dfa6197c 462
b5018cad 463(export '(local-address local-stream-address local-seq-address local-datagram-address))