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))