sockets/socket-methods.lisp

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