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