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