| 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 | |
| 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 | |
| 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 |
| 66 | format-address |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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)) |