net.sockets/socket-methods.lisp

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