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