net.sockets/socket-methods.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Various socket methods.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (defvar *socket-type-map*
   9   '(((:ipv4  :stream   :active  :default) . socket-stream-internet-active)
  10     ((:ipv6  :stream   :active  :default) . socket-stream-internet-active)
  11     ((:ipv4  :stream   :passive :default) . socket-stream-internet-passive)
  12     ((:ipv6  :stream   :passive :default) . socket-stream-internet-passive)
  13     ((:local :stream   :active  :default) . socket-stream-local-active)
  14     ((:local :stream   :passive :default) . socket-stream-local-passive)
  15     ((:local :datagram :active  :default) . socket-datagram-local-active)
  16     ((:ipv4  :datagram :active  :default) . socket-datagram-internet-active)
  17     ((:ipv6  :datagram :active  :default) . socket-datagram-internet-active)))
  18
  19 ;;; FIXME: should match :default to whatever protocol is the default.
  20 (defun select-socket-class (family type connect protocol)
  21   (or (cdr (assoc (list family type connect protocol) *socket-type-map*
  22                   :test #'equal))
  23       (error "No socket class found !!")))
  24
  25 ;;;; Shared Initialization
  26
  27 (defun translate-make-socket-keywords-to-constants (family type protocol)
  28   (let ((sf (ecase family
  29               (:ipv4  af-inet)
  30               (:ipv6  af-inet6)
  31               (:local af-local)))
  32         (st (ecase type
  33               (:stream   sock-stream)
  34               (:datagram sock-dgram)))
  35         (sp (cond
  36               ((integerp protocol) protocol)
  37               ((eq :default protocol) 0)
  38               (t (lookup-protocol protocol)))))
  39     (values sf st sp)))
  40
  41 (defmethod socket-os-fd ((socket socket))
  42   (fd-of socket))
  43
  44 (defmethod initialize-instance :after ((socket socket) &key
  45                                        file-descriptor family type
  46                                        (protocol :default))
  47   (with-accessors ((fd fd-of) (fam socket-family) (proto socket-protocol))
  48       socket
  49     (setf fd (or file-descriptor
  50                  (multiple-value-call #'%socket
  51                    (translate-make-socket-keywords-to-constants
  52                     family type protocol))))
  53     (setf fam family
  54           proto protocol)))
  55
  56 (defmethod (setf external-format-of) (external-format (socket passive-socket))
  57   (setf (slot-value socket 'external-format)
  58         (babel:ensure-external-format external-format)))
  59
  60 (defmethod initialize-instance :after ((socket passive-socket) &key external-format
  61                                        input-buffer-size output-buffer-size)
  62   ;; Makes CREATE-SOCKET simpler
  63   (declare (ignore input-buffer-size output-buffer-size))
  64   (setf (external-format-of socket) external-format))
  65
  66 (defmethod socket-type ((socket stream-socket))
  67   :stream)
  68
  69 (defmethod socket-type ((socket datagram-socket))
  70   :datagram)
  71
  72 (defun ipv6-socket-p (socket)
  73   "Return T if SOCKET is an AF_INET6 socket."
  74   (eq :ipv6 (socket-family socket)))
  75
  76 ;;;; Printing
  77
  78 (defun sock-fam (socket)
  79   (ecase (socket-family socket)
  80     (:ipv4 "IPv4")
  81     (:ipv6 "IPv6")))
  82
  83 (defmethod print-object ((socket socket-stream-internet-active) stream)
  84   (print-unreadable-object (socket stream :identity t)
  85     (format stream "active ~A stream socket" (sock-fam socket))
  86     (if (socket-connected-p socket)
  87         (multiple-value-bind (host port) (remote-name socket)
  88           (format stream " connected to ~A/~A"
  89                   (address-to-string host) port))
  90         (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
  91
  92 (defmethod print-object ((socket socket-stream-internet-passive) stream)
  93   (print-unreadable-object (socket stream :identity t)
  94     (format stream "passive ~A stream socket" (sock-fam socket))
  95     (if (socket-bound-p socket)
  96         (multiple-value-bind (host port) (local-name socket)
  97           (format stream " ~:[bound to~;waiting @~] ~A/~A"
  98                   (socket-listening-p socket)
  99                   (address-to-string host) port))
 100         (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
 101
 102 (defmethod print-object ((socket socket-stream-local-active) stream)
 103   (print-unreadable-object (socket stream :identity t)
 104     (format stream "active local stream socket")
 105     (if (socket-connected-p socket)
 106         (format stream " connected to ~S"
 107                 (address-to-string (remote-filename socket)))
 108         (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
 109
 110 (defmethod print-object ((socket socket-stream-local-passive) stream)
 111   (print-unreadable-object (socket stream :identity t)
 112     (format stream "passive local stream socket")
 113     (if (socket-bound-p socket)
 114         (format stream " ~:[bound to~;waiting @~] ~S"
 115                   (socket-listening-p socket)
 116                   (address-to-string (local-filename socket)))
 117         (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
 118
 119 (defmethod print-object ((socket socket-datagram-local-active) stream)
 120   (print-unreadable-object (socket stream :identity t)
 121     (format stream "local datagram socket")
 122     (if (socket-connected-p socket)
 123         (format stream " connected to ~S"
 124                 (address-to-string (remote-filename socket)))
 125         (if (fd-of socket)
 126             (format stream " waiting @ ~S" (address-to-string (local-filename socket)))
 127             (format stream ", closed" )))))
 128
 129 (defmethod print-object ((socket socket-datagram-internet-active) stream)
 130   (print-unreadable-object (socket stream :identity t)
 131     (format stream "~A datagram socket" (sock-fam socket))
 132     (if (socket-connected-p socket)
 133         (multiple-value-bind (host port) (remote-name socket)
 134           (format stream " connected to ~A/~A"
 135                   (address-to-string host) port))
 136         (if (fd-of socket)
 137             (multiple-value-bind (host port) (local-name socket)
 138               (format stream " waiting @ ~A/~A"
 139                       (address-to-string host) port))
 140             (format stream ", closed" )))))
 141
 142 ;;;; CLOSE
 143
 144 (defmethod close :around ((socket socket) &key abort)
 145   (declare (ignore abort))
 146   (call-next-method)
 147   (when (fd-of socket)
 148     (nix:close (fd-of socket)))
 149   (setf (fd-of socket) nil
 150         (slot-value socket 'bound) nil)
 151   (values socket))
 152
 153 (defmethod close :around ((socket passive-socket) &key abort)
 154   (declare (ignore abort))
 155   (call-next-method)
 156   (setf (slot-value socket 'listening) nil)
 157   (values socket))
 158
 159 (defmethod close ((socket socket) &key abort)
 160   (declare (ignore socket abort)))
 161
 162 (defmethod socket-open-p ((socket socket))
 163   (when (fd-of socket)
 164     (with-sockaddr-storage-and-socklen (ss size)
 165       (handler-case
 166           (%getsockname (fd-of socket) ss size)
 167         (nix:ebadf () nil)
 168         (socket-connection-reset-error () nil)
 169         (:no-error (_) (declare (ignore _)) t)))))
 170
 171 ;;;; GETSOCKNAME
 172
 173 (defun %local-name (socket)
 174   (with-sockaddr-storage-and-socklen (ss size)
 175     (%getsockname (fd-of socket) ss size)
 176     (sockaddr-storage->sockaddr ss)))
 177
 178 (defmethod local-name ((socket socket))
 179   (%local-name socket))
 180
 181 (defmethod local-host ((socket internet-socket))
 182   (nth-value 0 (%local-name socket)))
 183
 184 (defmethod local-port ((socket internet-socket))
 185   (nth-value 1 (%local-name socket)))
 186
 187 (defmethod local-filename ((socket local-socket))
 188   (%local-name socket))
 189
 190 ;;;; GETPEERNAME
 191
 192 (defun %remote-name (socket)
 193   (with-sockaddr-storage-and-socklen (ss size)
 194     (%getpeername (fd-of socket) ss size)
 195     (sockaddr-storage->sockaddr ss)))
 196
 197 (defmethod remote-name ((socket socket))
 198   (%remote-name socket))
 199
 200 (defmethod remote-host ((socket internet-socket))
 201   (nth-value 0 (%remote-name socket)))
 202
 203 (defmethod remote-port ((socket internet-socket))
 204   (nth-value 1 (%remote-name socket)))
 205
 206 (defmethod remote-filename ((socket local-socket))
 207   (%remote-name socket))
 208
 209 ;;;; BIND
 210
 211 (defmethod bind-address :before ((socket internet-socket) address
 212                                  &key (reuse-address t))
 213   (declare (ignore address))
 214   (when reuse-address
 215     (setf (socket-option socket :reuse-address) t)))
 216
 217 (defun bind-ipv4-address (fd address port)
 218   (with-sockaddr-in (sin address port)
 219     (%bind fd sin size-of-sockaddr-in)))
 220
 221 (defun bind-ipv6-address (fd address port)
 222   (with-sockaddr-in6 (sin6 address port)
 223     (%bind fd sin6 size-of-sockaddr-in6)))
 224
 225 (defmethod bind-address ((socket internet-socket) (address ipv4-address)
 226                          &key (port 0))
 227   (if (ipv6-socket-p socket)
 228       (bind-ipv6-address (fd-of socket)
 229                          (map-ipv4-vector-to-ipv6 (address-name address))
 230                          port)
 231       (bind-ipv4-address (fd-of socket) (address-name address) port))
 232   (values socket))
 233
 234 (defmethod bind-address ((socket internet-socket) (address ipv6-address)
 235                          &key (port 0))
 236   (bind-ipv6-address (fd-of socket) (address-name address) port)
 237   (values socket))
 238
 239 (defmethod bind-address ((socket local-socket) (address local-address) &key)
 240   (with-sockaddr-un (sun (address-name address))
 241     (%bind (fd-of socket) sun size-of-sockaddr-un))
 242   (values socket))
 243
 244 (defmethod bind-address :after ((socket socket) (address address) &key)
 245   (setf (slot-value socket 'bound) t))
 246
 247 ;;;; LISTEN
 248
 249 (defmethod listen-on ((socket passive-socket) &key backlog)
 250   (unless backlog (setf backlog (min *default-backlog-size*
 251                                      +max-backlog-size+)))
 252   (check-type backlog unsigned-byte "a non-negative integer")
 253   (%listen (fd-of socket) backlog)
 254   (setf (slot-value socket 'listening) t)
 255   (values socket))
 256
 257 (defmethod listen-on ((socket active-socket) &key)
 258   (error "You can't listen on active sockets."))
 259
 260 ;;;; ACCEPT
 261
 262 (defmethod accept-connection ((socket active-socket) &key)
 263   (error "You can't accept connections on active sockets."))
 264
 265 (defmethod accept-connection ((socket passive-socket) &key external-format
 266                               input-buffer-size output-buffer-size
 267                               (wait t) (timeout nil))
 268   (flet ((make-client-socket (fd)
 269            (make-instance (active-class socket)
 270                           :file-descriptor fd
 271                           :external-format (or external-format
 272                                                (external-format-of socket))
 273                           :input-buffer-size input-buffer-size
 274                           :output-buffer-size output-buffer-size)))
 275     (ignore-some-conditions (iomux:poll-timeout)
 276       (when wait (iomux:wait-until-fd-ready (fd-of socket) :read timeout t))
 277       (with-sockaddr-storage-and-socklen (ss size)
 278         (ignore-some-conditions (nix:ewouldblock)
 279           (make-client-socket (%accept (fd-of socket) ss size)))))))
 280
 281 ;;;; CONNECT
 282
 283 (defun ipv4-connect (fd address port)
 284   (with-sockaddr-in (sin address port)
 285     (%connect fd sin size-of-sockaddr-in)))
 286
 287 (defun ipv6-connect (fd address port)
 288   (with-sockaddr-in6 (sin6 address port)
 289     (%connect fd sin6 size-of-sockaddr-in6)))
 290
 291 (defun call-with-socket-to-wait-connect (socket thunk wait timeout)
 292   (handler-case
 293       (funcall thunk)
 294     (nix:ewouldblock (err)
 295       (cond
 296         (wait
 297          (iomux:wait-until-fd-ready (fd-of socket) :write timeout t)
 298          (let ((errcode (socket-option socket :error)))
 299            (unless (zerop errcode)
 300              (signal-socket-error errcode))))
 301         (t (error err))))))
 302
 303 (defmacro with-socket-to-wait-connect ((socket wait timeout) &body body)
 304   `(call-with-socket-to-wait-connect ,socket #'(lambda () ,@body) ,wait ,timeout))
 305
 306 (defmethod connect ((socket internet-socket) (address ipv4-address)
 307                     &key (port 0) (wait t) (timeout nil))
 308   (with-socket-to-wait-connect (socket wait timeout)
 309     (if (ipv6-socket-p socket)
 310         (ipv6-connect (fd-of socket)
 311                       (map-ipv4-vector-to-ipv6 (address-name address))
 312                       port)
 313         (ipv4-connect (fd-of socket) (address-name address) port)))
 314   (values socket))
 315
 316 (defmethod connect ((socket internet-socket) (address ipv6-address)
 317                     &key (port 0) (timeout nil))
 318   (with-socket-to-wait-connect (socket wait timeout)
 319     (ipv6-connect (fd-of socket) (address-name address) port))
 320   (values socket))
 321
 322 (defmethod connect ((socket local-socket) (address local-address) &key)
 323   (with-sockaddr-un (sun (address-name address))
 324     (%connect (fd-of socket) sun size-of-sockaddr-un))
 325   (values socket))
 326
 327 (defmethod connect ((socket passive-socket) address &key)
 328   (declare (ignore address))
 329   (error "You cannot connect passive sockets."))
 330
 331 (defmethod socket-connected-p ((socket socket))
 332   (when (fd-of socket)
 333     (with-sockaddr-storage-and-socklen (ss size)
 334       (handler-case
 335           (%getpeername (fd-of socket) ss size)
 336         (socket-not-connected-error () nil)
 337         (:no-error (_) (declare (ignore _)) t)))))
 338
 339 ;;;; DISCONNECT
 340
 341 (defmethod disconnect :before ((socket socket))
 342   (unless (typep socket 'datagram-socket)
 343     (error "You can only disconnect active datagram sockets.")))
 344
 345 (defmethod disconnect ((socket datagram-socket))
 346   (with-foreign-object (sin 'sockaddr-in)
 347     (bzero sin size-of-sockaddr-in)
 348     (setf (foreign-slot-value sin 'sockaddr-in 'addr) af-unspec)
 349     (%connect (fd-of socket) sin size-of-sockaddr-in)
 350     (values socket)))
 351
 352 ;;;; SHUTDOWN
 353
 354 (defmethod shutdown ((socket socket) &key read write)
 355   (assert (or read write) (read write)
 356           "You must select at least one direction to shut down.")
 357   (%shutdown (fd-of socket)
 358              (multiple-value-case ((read write))
 359                ((_   nil) shut-rd)
 360                ((nil _)   shut-wr)
 361                (t         shut-rdwr)))
 362   (values socket))
 363
 364 ;;;; Socket flag definition
 365
 366 (defmacro define-socket-flag (place name value platform)
 367   (let ((val (cond ((or (not platform)
 368                         (featurep platform)) value)
 369                    ((not (featurep platform)) 0))))
 370     `(pushnew (cons ,name ,val) ,place)))
 371
 372 (defmacro define-socket-flags (place &body definitions)
 373   (flet ((dflag (form)
 374            (destructuring-bind (name value &optional platform) form
 375              `(define-socket-flag ,place ,name ,value ,platform))))
 376     `(progn
 377        ,@(mapcar #'dflag definitions))))
 378
 379 ;;;; SENDTO
 380
 381 (defvar *sendto-flags* ())
 382
 383 (define-socket-flags *sendto-flags*
 384   (:dont-route    msg-dontroute)
 385   (:dont-wait     msg-dontwait  (:not :windows))
 386   (:out-of-band   msg-oob)
 387   (:more          msg-more      :linux)
 388   (:confirm       msg-confirm   :linux))
 389
 390 (defun %normalize-send-buffer (buff start end ef)
 391   (check-bounds buff start end)
 392   (etypecase buff
 393     (ub8-sarray (values buff start (- end start)))
 394     (string     (let ((vector (%to-octets buff ef start end)))
 395                   (values vector 0 (length vector))))
 396     (vector     (values (coerce buff 'ub8-sarray)
 397                         start (- end start)))))
 398
 399 (defun %%send-to (fd ss got-peer buffer start end flags ef)
 400   (multiple-value-bind (buff start-offset bufflen)
 401       (%normalize-send-buffer buffer start end ef)
 402     (with-pointer-to-vector-data (buff-sap buff)
 403       (incf-pointer buff-sap start-offset)
 404       (loop
 405          (restart-case
 406              (return-from %%send-to
 407                (%sendto fd buff-sap bufflen flags
 408                         (if got-peer ss (null-pointer))
 409                         (if got-peer (sockaddr-size ss) 0)))
 410            (ignore ()
 411              :report "Ignore this socket condition"
 412              (return-from %%send-to 0))
 413            (continue (&optional (wait 0))
 414              :report "Try to send data again"
 415              (when (plusp wait) (sleep wait))))))))
 416
 417 (defun %inet-send-to (socket buffer start end remote-host remote-port flags)
 418   (with-sockaddr-storage (ss)
 419     (when remote-host
 420       (sockaddr->sockaddr-storage ss (ensure-hostname remote-host)
 421                                   (ensure-numerical-service remote-port)))
 422     (%%send-to (fd-of socket) ss (if remote-host t) buffer start end flags
 423                (external-format-of socket))))
 424
 425 (defun %local-send-to (socket buffer start end remote-filename flags)
 426   (with-sockaddr-storage (ss)
 427     (when remote-filename
 428       (sockaddr->sockaddr-storage ss (ensure-address remote-filename :family :local) 0))
 429     (%%send-to (fd-of socket) ss (if remote-filename t) buffer start end flags
 430                (external-format-of socket))))
 431
 432 (defmethod send-to ((socket internet-socket) buffer &rest args
 433                     &key (start 0) end remote-host (remote-port 0) (ipv6 *ipv6*))
 434   (let ((*ipv6* ipv6))
 435     (%inet-send-to socket buffer start end remote-host remote-port
 436                    (compute-flags *sendto-flags* args))))
 437
 438 (defmethod send-to ((socket local-socket) buffer &rest args
 439                     &key (start 0) end remote-filename)
 440   (%local-send-to socket buffer start end remote-filename
 441                   (compute-flags *sendto-flags* args)))
 442
 443 (define-compiler-macro send-to (&whole form socket buffer &rest args
 444                                 &key (start 0) end remote-host (remote-port 0)
 445                                 remote-filename (ipv6 '*ipv6*) &allow-other-keys)
 446   (let ((flags (compute-flags *sendto-flags* args)))
 447     (cond (flags
 448            (once-only (socket buffer start end remote-host
 449                        remote-port remote-filename flags)
 450              `(etypecase ,socket
 451                 (internet-socket
 452                  (let ((*ipv6* ,ipv6))
 453                    (%inet-send-to ,socket ,buffer ,start ,end
 454                                   ,remote-host ,remote-port ,flags)))
 455                 (local-socket
 456                  (%local-send-to ,socket ,buffer ,start ,end
 457                                  ,remote-filename ,flags)))))
 458           (t form))))
 459
 460 ;;;; RECVFROM
 461
 462 (defvar *recvfrom-flags* ())
 463
 464 (define-socket-flags *recvfrom-flags*
 465   (:out-of-band msg-oob)
 466   (:peek        msg-peek)
 467   (:wait-all    msg-waitall  (:not :windows))
 468   (:dont-wait   msg-dontwait (:not :windows)))
 469
 470 (defun allocate-ub8-buffer-for-string (length ef)
 471   (let* ((units-per-char (babel-encodings:enc-max-units-per-char
 472                           (babel:external-format-encoding ef)))
 473          (length (* units-per-char length)))
 474     (values (make-array length :element-type 'ub8)
 475             0 length)))
 476
 477 (defun %normalize-receive-buffer (buff start end ef)
 478   (etypecase buff
 479     (ub8-sarray (values buff start (- end start)))
 480     (string     (allocate-ub8-buffer-for-string (- end start) ef))))
 481
 482 (defun %%receive-from (fd ss size buffer start end flags ef)
 483   (check-bounds buffer start end)
 484   (multiple-value-bind (buff start-offset bufflen)
 485       (%normalize-receive-buffer buffer start end ef)
 486     (with-pointer-to-vector-data (buff-sap buff)
 487       (incf-pointer buff-sap start-offset)
 488       (loop
 489          (restart-case
 490              (let ((nbytes (%recvfrom fd buff-sap bufflen flags ss size)))
 491                (return-from %%receive-from
 492                  (if (stringp buffer)
 493                      ;; FIXME: convert the octets directly into the buffer
 494                      (let ((str (babel:octets-to-string buff :start 0 :end nbytes
 495                                                         :encoding (babel:external-format-encoding ef)
 496                                                         :errorp nil)))
 497                        (replace buffer str :start1 start :end1 end)
 498                        (- end start))
 499                      nbytes)))
 500            (ignore ()
 501              :report "Ignore this socket condition"
 502              (return-from %%receive-from 0))
 503            (continue (&optional (wait 0))
 504              :report "Try to receive data again"
 505              (when (plusp wait) (sleep wait))))))))
 506
 507 (declaim (inline %receive-from-stream-socket))
 508 (defun %receive-from-stream-socket (socket buffer start end flags)
 509   (with-sockaddr-storage-and-socklen (ss size)
 510     (let ((nelements (%%receive-from (fd-of socket) ss size buffer start end
 511                                      flags (external-format-of socket))))
 512       (values buffer nelements))))
 513
 514 (declaim (inline %receive-from-datagram-socket))
 515 (defun %receive-from-datagram-socket (socket buffer start end flags)
 516   (with-sockaddr-storage-and-socklen (ss size)
 517     (let ((nelements (%%receive-from (fd-of socket) ss size buffer start end
 518                                      flags (external-format-of socket))))
 519       (multiple-value-call #'values buffer nelements
 520                            (sockaddr-storage->sockaddr ss)))))
 521
 522 (defun %receive-from (socket buffer start end size flags)
 523   (unless buffer
 524     (check-type size unsigned-byte "a non-negative integer")
 525     (setf buffer (make-array size :element-type 'ub8)
 526           start 0 end size))
 527   (etypecase socket
 528     (stream-socket (%receive-from-stream-socket socket buffer start end flags))
 529     (datagram-socket (%receive-from-datagram-socket socket buffer start end flags))))
 530
 531 (defmethod receive-from ((socket active-socket) &rest args
 532                          &key buffer size (start 0) end)
 533   (%receive-from socket buffer start end size
 534                  (compute-flags *recvfrom-flags* args)))
 535
 536 (define-compiler-macro receive-from (&whole form socket &rest args
 537                                      &key buffer size (start 0) end &allow-other-keys)
 538   (let ((flags (compute-flags *recvfrom-flags* args)))
 539     (cond (flags `(%receive-from ,socket ,buffer ,start ,end ,size ,flags))
 540           (t form))))