src/sockets/socket-methods.lisp

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