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 @"
 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 @"
 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 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       (sockaddr-storage->sockaddr ss))))
 227
 228 (defmethod socket-address ((socket socket))
 229   (nth-value 0 (local-name socket)))
 230
 231 (defmethod socket-port ((socket internet-socket))
 232   (nth-value 1 (local-name socket)))
 233
 234
 235 ;;;;;;;;;;;;;;;;;;;
 236 ;;  GETPEERNAME  ;;
 237 ;;;;;;;;;;;;;;;;;;;
 238
 239 (defmethod remote-name ((socket socket))
 240   (with-foreign-object (ss 'et:sockaddr-storage)
 241     (et:bzero ss et:size-of-sockaddr-storage)
 242     (with-socklen (size et:size-of-sockaddr-storage)
 243       (with-socket-error-filter
 244         (et:getpeername (fd-of socket) ss size))
 245       (sockaddr-storage->sockaddr ss))))
 246
 247
 248 ;;;;;;;;;;;;
 249 ;;  BIND  ;;
 250 ;;;;;;;;;;;;
 251
 252 (defmethod bind-address :before ((socket internet-socket)
 253                                  address &key (reuse-address t))
 254   (declare (ignore address))
 255   (when reuse-address
 256     (set-socket-option socket :reuse-address :value t)))
 257
 258 (defun bind-ipv4-address (fd address port)
 259   (with-sockaddr-in (sin address port)
 260     (with-socket-error-filter
 261       (et:bind fd sin et:size-of-sockaddr-in))))
 262
 263 (defun bind-ipv6-address (fd address port)
 264   (with-sockaddr-in6 (sin6 address port)
 265     (with-socket-error-filter
 266       (et:bind fd sin6 et:size-of-sockaddr-in6))))
 267
 268 (defmethod bind-address ((socket internet-socket)
 269                          (address ipv4addr)
 270                          &key (port 0))
 271   (if (eql (socket-family socket) :ipv6)
 272       (bind-ipv6-address (fd-of socket)
 273                          (map-ipv4-vector-to-ipv6 (name address))
 274                          port)
 275       (bind-ipv4-address (fd-of socket) (name address) port))
 276   (values socket))
 277
 278 (defmethod bind-address ((socket internet-socket)
 279                          (address ipv6addr)
 280                          &key (port 0))
 281   (bind-ipv6-address (fd-of socket) (name address) port)
 282   (values socket))
 283
 284 (defmethod bind-address ((socket local-socket)
 285                          (address localaddr) &key)
 286   (with-sockaddr-un (sun (name address))
 287     (with-socket-error-filter
 288       (et:bind (fd-of socket) sun et:size-of-sockaddr-un)))
 289   (values socket))
 290
 291 (defmethod bind-address :after ((socket socket)
 292                                 (address sockaddr) &key)
 293   (setf (slot-value socket 'bound) t))
 294
 295
 296 ;;;;;;;;;;;;;;
 297 ;;  LISTEN  ;;
 298 ;;;;;;;;;;;;;;
 299
 300 (defmethod socket-listen ((socket passive-socket)
 301                           &key backlog)
 302   (unless backlog (setf backlog (min *default-backlog-size*
 303                                      +max-backlog-size+)))
 304   (check-type backlog unsigned-byte "a non-negative integer")
 305   (with-socket-error-filter
 306     (et:listen (fd-of socket) backlog))
 307   (setf (slot-value socket 'listening) t)
 308   (values socket))
 309
 310 (defmethod socket-listen ((socket active-socket)
 311                           &key backlog)
 312   (declare (ignore backlog))
 313   (error "You can't listen on active sockets."))
 314
 315
 316 ;;;;;;;;;;;;;;
 317 ;;  ACCEPT  ;;
 318 ;;;;;;;;;;;;;;
 319
 320 (defmethod accept-connection ((socket active-socket))
 321   (error "You can't accept connections on active sockets."))
 322
 323 (defmethod accept-connection ((socket passive-socket))
 324   (flet ((make-client-socket (fd)
 325            (make-instance (active-class socket)
 326                           :external-format (external-format-of socket)
 327                           :file-descriptor fd)))
 328     (with-foreign-object (ss 'et:sockaddr-storage)
 329       (et:bzero ss et:size-of-sockaddr-storage)
 330       (with-socklen (size et:size-of-sockaddr-storage)
 331         (with-socket-error-filter
 332           (handler-case
 333               (make-client-socket (et:accept (fd-of socket) ss size))
 334             (et:ewouldblock ())))))))
 335
 336
 337 ;;;;;;;;;;;;;;;
 338 ;;  CONNECT  ;;
 339 ;;;;;;;;;;;;;;;
 340
 341 #+freebsd
 342 (defmethod connect :before ((socket active-socket)
 343                             sockaddr &key)
 344   (declare (ignore sockaddr))
 345   (set-socket-option socket :no-sigpipe :value t))
 346
 347 (defun ipv4-connect (fd address port)
 348   (with-sockaddr-in (sin address port)
 349     (with-socket-error-filter
 350       (et:connect fd sin et:size-of-sockaddr-in))))
 351
 352 (defun ipv6-connect (fd address port)
 353   (with-sockaddr-in6 (sin6 address port)
 354     (with-socket-error-filter
 355       (et:connect fd sin6 et:size-of-sockaddr-in6))))
 356
 357 (defmethod connect ((socket internet-socket)
 358                     (address ipv4addr) &key (port 0))
 359   (if (eql (socket-family socket) :ipv6)
 360       (ipv6-connect (fd-of socket)
 361                     (map-ipv4-vector-to-ipv6 (name address))
 362                     port)
 363       (ipv4-connect (fd-of socket) (name address) port))
 364   (values socket))
 365
 366 (defmethod connect ((socket internet-socket)
 367                     (address ipv6addr) &key (port 0))
 368   (ipv6-connect (fd-of socket) (name address) port)
 369   (values socket))
 370
 371 (defmethod connect ((socket local-socket)
 372                     (address localaddr) &key)
 373   (with-sockaddr-un (sun (name address))
 374     (with-socket-error-filter
 375       (et:connect (fd-of socket) sun et:size-of-sockaddr-un)))
 376   (values socket))
 377
 378 (defmethod connect ((socket passive-socket) address &key)
 379   (declare (ignore address))
 380   (error "You cannot connect passive sockets."))
 381
 382 (defmethod socket-connected-p ((socket socket))
 383   (unless (fd-of socket)
 384     (return-from socket-connected-p nil))
 385   (with-socket-error-filter
 386     (handler-case
 387         (with-foreign-object (ss 'et:sockaddr-storage)
 388           (et:bzero ss et:size-of-sockaddr-storage)
 389           (with-socklen (size et:size-of-sockaddr-storage)
 390             (et:getpeername (fd-of socket) ss size)
 391             t))
 392       (et:enotconn ()))))
 393
 394
 395 ;;;;;;;;;;;;;;;;
 396 ;;  SHUTDOWN  ;;
 397 ;;;;;;;;;;;;;;;;
 398
 399 (defmethod shutdown ((socket active-socket) direction)
 400   (check-type direction (member :read :write :read-write)
 401               "valid direction specifier")
 402   (with-socket-error-filter
 403     (et:shutdown (fd-of socket)
 404                  (ecase direction
 405                    (:read et:shut-rd)
 406                    (:write et:shut-wr)
 407                    (:read-write et:shut-rdwr))))
 408   (values socket))
 409
 410 (defmethod shutdown ((socket passive-socket) direction)
 411   (declare (ignore direction))
 412   (error "You cannot shut down passive sockets."))
 413
 414
 415 ;;;;;;;;;;;;
 416 ;;  SEND  ;;
 417 ;;;;;;;;;;;;
 418
 419 (defun %normalize-send-buffer (buff start end ef)
 420   (setf (values start end) (%check-bounds buff start end))
 421   (etypecase buff
 422     (ub8-sarray (values buff start (- end start)))
 423     (ub8-vector (values (coerce buff 'ub8-sarray)
 424                         start (- end start)))
 425     (string     (values (%to-octets buff ef start end)
 426                         0 (- end start)))))
 427
 428 (defmethod socket-send ((buffer array)
 429                         (socket active-socket) &key (start 0) end
 430                         remote-address remote-port end-of-record
 431                         dont-route dont-wait no-signal
 432                         out-of-band #+linux more #+linux confirm)
 433   (check-type start unsigned-byte
 434               "a non-negative unsigned integer")
 435   (check-type end (or unsigned-byte null)
 436               "a non-negative unsigned integer or NIL")
 437   (when (or remote-port remote-address)
 438     (check-type remote-address sockaddr "a network address")
 439     (check-type remote-port (unsigned-byte 16) "a valid IP port number"))
 440   (let ((flags (logior (if end-of-record et:msg-eor 0)
 441                        (if dont-route et:msg-dontroute 0)
 442                        (if dont-wait  et:msg-dontwait 0)
 443                        (if no-signal  et:msg-nosignal 0)
 444                        (if out-of-band et:msg-oob 0)
 445                        #+linux (if more et:msg-more 0)
 446                        #+linux (if confirm et:msg-confirm 0))))
 447     (when (and (ipv4-address-p remote-address)
 448                (eql (socket-family socket) :ipv6))
 449       (setf remote-address (map-ipv4-address->ipv6 remote-address)))
 450     (multiple-value-bind (buff start-offset bufflen)
 451         (%normalize-send-buffer buffer start end (external-format-of socket))
 452       (with-foreign-object (ss 'et:sockaddr-storage)
 453         (et:bzero ss et:size-of-sockaddr-storage)
 454         (when remote-address
 455           (sockaddr->sockaddr-storage ss remote-address remote-port))
 456         (with-pointer-to-vector-data (buff-sap buff)
 457           (incf-pointer buff-sap start-offset)
 458           (with-socket-error-filter
 459             (return-from socket-send
 460               (et:sendto (fd-of socket)
 461                          buff-sap bufflen
 462                          flags
 463                          (if remote-address ss (null-pointer))
 464                          (if remote-address et:size-of-sockaddr-storage 0)))))))))
 465
 466 (defmethod socket-send (buffer (socket passive-socket) &key)
 467   (declare (ignore buffer))
 468   (error "You cannot send data on a passive socket."))
 469
 470
 471 ;;;;;;;;;;;;
 472 ;;  RECV  ;;
 473 ;;;;;;;;;;;;
 474
 475 (defun %normalize-receive-buffer (buff start end)
 476   (setf (values start end) (%check-bounds buff start end))
 477   (etypecase buff
 478     ((simple-array ub8 (*)) (values buff start (- end start)))))
 479
 480 (defun calc-recvfrom-flags (out-of-band peek wait-all dont-wait no-signal)
 481   (logior (if out-of-band et:msg-oob 0)
 482           (if peek        et:msg-peek 0)
 483           (if wait-all    et:msg-waitall 0)
 484           (if dont-wait   et:msg-dontwait 0)
 485           (if no-signal   et:msg-nosignal 0)))
 486
 487 (defun %do-recvfrom (buffer ss fd flags start end)
 488   (multiple-value-bind (buff start-offset bufflen)
 489       (%normalize-receive-buffer buffer start end)
 490     (with-socklen (size et:size-of-sockaddr-storage)
 491       (et:bzero ss et:size-of-sockaddr-storage)
 492       (with-pointer-to-vector-data (buff-sap buff)
 493         (incf-pointer buff-sap start-offset)
 494         (with-socket-error-filter
 495           (return-from %do-recvfrom
 496             (et:recvfrom fd buff-sap bufflen flags ss size)))))))
 497
 498 (defmethod socket-receive ((buffer array) (socket stream-socket) &key (start 0) end
 499                            out-of-band peek wait-all dont-wait no-signal)
 500   (with-foreign-object (ss 'et:sockaddr-storage)
 501     (let* ((flags (calc-recvfrom-flags out-of-band peek wait-all dont-wait no-signal))
 502            (bytes-received (%do-recvfrom buffer ss (fd-of socket) flags start end)))
 503       (values buffer bytes-received))))
 504
 505 (defmethod socket-receive ((buffer array) (socket datagram-socket) &key (start 0) end
 506                            out-of-band peek wait-all dont-wait no-signal)
 507   (with-foreign-object (ss 'et:sockaddr-storage)
 508     (let* ((flags (calc-recvfrom-flags out-of-band peek wait-all dont-wait no-signal))
 509            (bytes-received (%do-recvfrom buffer ss (fd-of socket) flags start end)))
 510       (multiple-value-bind (remote-address remote-port)
 511           (sockaddr-storage->sockaddr ss)
 512         (values buffer bytes-received remote-address remote-port)))))
 513
 514 (defmethod socket-receive (buffer (socket passive-socket) &key)
 515   (declare (ignore buffer))
 516   (error "You cannot receive data from a passive socket."))
 517
 518
 519 ;;
 520 ;; Only for datagram sockets
 521 ;;
 522
 523 (defmethod disconnect :before ((socket active-socket))
 524   (unless (typep socket 'datagram-socket)
 525     (error "You can only disconnect active datagram sockets.")))
 526
 527 (defmethod disconnect ((socket datagram-socket))
 528   (with-foreign-object (sin 'et:sockaddr-in)
 529     (et:bzero sin et:size-of-sockaddr-in)
 530     (setf (foreign-slot-value sin 'et:sockaddr-in 'et:addr) et:af-unspec)
 531     (with-socket-error-filter
 532       (et:connect (fd-of socket) sin et:size-of-sockaddr-in))))