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