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