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 :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         (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
 117
 118 (defmethod print-object ((socket socket-stream-internet-passive) stream)
 119   (print-unreadable-object (socket stream :identity t)
 120     (format stream "passive ~A stream socket" (sock-fam socket))
 121     (if (socket-bound-p socket)
 122         (multiple-value-bind (addr port) (local-name socket)
 123           (format stream " ~:[bound to~;waiting @~] ~A/~A"
 124                   (socket-listening-p socket)
 125                   (sockaddr->presentation addr) port))
 126         (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
 127
 128 (defmethod print-object ((socket socket-stream-local-active) stream)
 129   (print-unreadable-object (socket stream :identity t)
 130     (format stream "active local stream socket")
 131     (if (socket-connected-p socket)
 132         (format stream " connected to ~A"
 133                 (sockaddr->presentation (remote-address socket)))
 134         (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
 135
 136 (defmethod print-object ((socket socket-stream-local-passive) stream)
 137   (print-unreadable-object (socket stream :identity t)
 138     (format stream "passive local stream socket")
 139     (if (socket-bound-p socket)
 140         (format stream " ~:[bound to~;waiting @~] ~A"
 141                   (socket-listening-p socket)
 142                   (sockaddr->presentation (local-address socket)))
 143         (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
 144
 145 (defmethod print-object ((socket socket-datagram-local-active) stream)
 146   (print-unreadable-object (socket stream :identity t)
 147     (format stream "local datagram socket")
 148     (if (socket-connected-p socket)
 149         (format stream " connected to ~A"
 150                 (sockaddr->presentation (remote-address socket)))
 151         (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
 152
 153 (defmethod print-object ((socket socket-datagram-internet-active) stream)
 154   (print-unreadable-object (socket stream :identity t)
 155     (format stream "~A datagram socket" (sock-fam socket))
 156     (if (socket-connected-p socket)
 157         (multiple-value-bind (addr port) (remote-name socket)
 158           (format stream " connected to ~A/~A"
 159                   (sockaddr->presentation addr) port))
 160         (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
 161
 162
 163 ;;;;;;;;;;;;;
 164 ;;  CLOSE  ;;
 165 ;;;;;;;;;;;;;
 166
 167 (defmethod close :around ((socket socket) &key abort)
 168   (declare (ignore abort))
 169   (call-next-method)
 170   (when (fd-of socket)
 171     (with-socket-error-filter
 172       (et:close (fd-of socket))))
 173   (setf (fd-of socket) nil
 174         (slot-value socket 'bound) nil)
 175   (values socket))
 176
 177 (defmethod close :around ((socket passive-socket) &key abort)
 178   (declare (ignore abort))
 179   (call-next-method)
 180   (setf (slot-value socket 'listening) nil)
 181   (values socket))
 182
 183 (defmethod close ((socket socket) &key abort)
 184   (declare (ignore socket abort)))
 185
 186 (defmethod socket-open-p ((socket socket))
 187   (unless (fd-of socket)
 188     (return-from socket-open-p nil))
 189   (with-socket-error-filter
 190     (handler-case
 191         (with-foreign-object (ss 'et:sockaddr-storage)
 192           (et:bzero ss et:size-of-sockaddr-storage)
 193           (with-socklen (size et:size-of-sockaddr-storage)
 194             (et:getsockname (fd-of socket) ss size)
 195             t))
 196       (et:ebadf ())
 197       #+freebsd (et:econnreset ()))))
 198
 199
 200 ;;;;;;;;;;;;;;;;;;;
 201 ;;  GETSOCKNAME  ;;
 202 ;;;;;;;;;;;;;;;;;;;
 203
 204 (defmethod local-name ((socket socket))
 205   (with-foreign-object (ss 'et:sockaddr-storage)
 206     (et:bzero ss et:size-of-sockaddr-storage)
 207     (with-socklen (size et:size-of-sockaddr-storage)
 208       (with-socket-error-filter
 209         (et:getsockname (fd-of socket) ss size))
 210       (sockaddr-storage->sockaddr ss))))
 211
 212 (defmethod local-address ((socket socket))
 213   (nth-value 0 (local-name socket)))
 214
 215 (defmethod local-port ((socket internet-socket))
 216   (nth-value 1 (local-name socket)))
 217
 218
 219 ;;;;;;;;;;;;;;;;;;;
 220 ;;  GETPEERNAME  ;;
 221 ;;;;;;;;;;;;;;;;;;;
 222
 223 (defmethod remote-name ((socket socket))
 224   (with-foreign-object (ss 'et:sockaddr-storage)
 225     (et:bzero ss et:size-of-sockaddr-storage)
 226     (with-socklen (size et:size-of-sockaddr-storage)
 227       (with-socket-error-filter
 228         (et:getpeername (fd-of socket) ss size))
 229       (sockaddr-storage->sockaddr ss))))
 230
 231 (defmethod remote-address ((socket socket))
 232   (nth-value 0 (remote-name socket)))
 233
 234 (defmethod remote-port ((socket internet-socket))
 235   (nth-value 1 (remote-name socket)))
 236
 237
 238 ;;;;;;;;;;;;
 239 ;;  BIND  ;;
 240 ;;;;;;;;;;;;
 241
 242 (defmethod bind-address :before ((socket internet-socket)
 243                                  address &key (reuse-address t))
 244   (declare (ignore address))
 245   (when reuse-address
 246     (set-socket-option socket :reuse-address :value t)))
 247
 248 (defun bind-ipv4-address (fd address port)
 249   (with-sockaddr-in (sin address port)
 250     (with-socket-error-filter
 251       (et:bind fd sin et:size-of-sockaddr-in))))
 252
 253 (defun bind-ipv6-address (fd address port)
 254   (with-sockaddr-in6 (sin6 address port)
 255     (with-socket-error-filter
 256       (et:bind fd sin6 et:size-of-sockaddr-in6))))
 257
 258 (defmethod bind-address ((socket internet-socket)
 259                          (address ipv4addr)
 260                          &key (port 0))
 261   (if (eql (socket-family socket) :ipv6)
 262       (bind-ipv6-address (fd-of socket)
 263                          (map-ipv4-vector-to-ipv6 (name address))
 264                          port)
 265       (bind-ipv4-address (fd-of socket) (name address) port))
 266   (values socket))
 267
 268 (defmethod bind-address ((socket internet-socket)
 269                          (address ipv6addr)
 270                          &key (port 0))
 271   (bind-ipv6-address (fd-of socket) (name address) port)
 272   (values socket))
 273
 274 (defmethod bind-address ((socket local-socket)
 275                          (address localaddr) &key)
 276   (with-sockaddr-un (sun (name address))
 277     (with-socket-error-filter
 278       (et:bind (fd-of socket) sun et:size-of-sockaddr-un)))
 279   (values socket))
 280
 281 (defmethod bind-address :after ((socket socket)
 282                                 (address sockaddr) &key)
 283   (setf (slot-value socket 'bound) t))
 284
 285
 286 ;;;;;;;;;;;;;;
 287 ;;  LISTEN  ;;
 288 ;;;;;;;;;;;;;;
 289
 290 (defmethod socket-listen ((socket passive-socket)
 291                           &key backlog)
 292   (unless backlog (setf backlog (min *default-backlog-size*
 293                                      +max-backlog-size+)))
 294   (check-type backlog unsigned-byte "a non-negative integer")
 295   (with-socket-error-filter
 296     (et:listen (fd-of socket) backlog))
 297   (setf (slot-value socket 'listening) t)
 298   (values socket))
 299
 300 (defmethod socket-listen ((socket active-socket)
 301                           &key backlog)
 302   (declare (ignore backlog))
 303   (error "You can't listen on active sockets."))
 304
 305
 306 ;;;;;;;;;;;;;;
 307 ;;  ACCEPT  ;;
 308 ;;;;;;;;;;;;;;
 309
 310 (defmethod accept-connection ((socket active-socket))
 311   (error "You can't accept connections on active sockets."))
 312
 313 (defmethod accept-connection ((socket passive-socket))
 314   (flet ((make-client-socket (fd)
 315            (make-instance (active-class socket)
 316                           :external-format (external-format-of socket)
 317                           :file-descriptor fd)))
 318     (with-foreign-object (ss 'et:sockaddr-storage)
 319       (et:bzero ss et:size-of-sockaddr-storage)
 320       (with-socklen (size et:size-of-sockaddr-storage)
 321         (with-socket-error-filter
 322           (handler-case
 323               (make-client-socket (et:accept (fd-of socket) ss size))
 324             (et:ewouldblock ())))))))
 325
 326
 327 ;;;;;;;;;;;;;;;
 328 ;;  CONNECT  ;;
 329 ;;;;;;;;;;;;;;;
 330
 331 #+freebsd
 332 (defmethod connect :before ((socket active-socket)
 333                             sockaddr &key)
 334   (declare (ignore sockaddr))
 335   (set-socket-option socket :no-sigpipe :value t))
 336
 337 (defun ipv4-connect (fd address port)
 338   (with-sockaddr-in (sin address port)
 339     (with-socket-error-filter
 340       (et:connect fd sin et:size-of-sockaddr-in))))
 341
 342 (defun ipv6-connect (fd address port)
 343   (with-sockaddr-in6 (sin6 address port)
 344     (with-socket-error-filter
 345       (et:connect fd sin6 et:size-of-sockaddr-in6))))
 346
 347 (defmethod connect ((socket internet-socket)
 348                     (address ipv4addr) &key (port 0))
 349   (if (eql (socket-family socket) :ipv6)
 350       (ipv6-connect (fd-of socket)
 351                     (map-ipv4-vector-to-ipv6 (name address))
 352                     port)
 353       (ipv4-connect (fd-of socket) (name address) port))
 354   (values socket))
 355
 356 (defmethod connect ((socket internet-socket)
 357                     (address ipv6addr) &key (port 0))
 358   (ipv6-connect (fd-of socket) (name address) port)
 359   (values socket))
 360
 361 (defmethod connect ((socket local-socket)
 362                     (address localaddr) &key)
 363   (with-sockaddr-un (sun (name address))
 364     (with-socket-error-filter
 365       (et:connect (fd-of socket) sun et:size-of-sockaddr-un)))
 366   (values socket))
 367
 368 (defmethod connect ((socket passive-socket) address &key)
 369   (declare (ignore address))
 370   (error "You cannot connect passive sockets."))
 371
 372 (defmethod socket-connected-p ((socket socket))
 373   (unless (fd-of socket)
 374     (return-from socket-connected-p nil))
 375   (with-socket-error-filter
 376     (handler-case
 377         (with-foreign-object (ss 'et:sockaddr-storage)
 378           (et:bzero ss et:size-of-sockaddr-storage)
 379           (with-socklen (size et:size-of-sockaddr-storage)
 380             (et:getpeername (fd-of socket) ss size)
 381             t))
 382       (et:enotconn ()))))
 383
 384
 385 ;;;;;;;;;;;;;;;;
 386 ;;  SHUTDOWN  ;;
 387 ;;;;;;;;;;;;;;;;
 388
 389 (defmethod shutdown ((socket active-socket) direction)
 390   (check-type direction (member :read :write :read-write)
 391               "valid direction specifier")
 392   (with-socket-error-filter
 393     (et:shutdown (fd-of socket)
 394                  (ecase direction
 395                    (:read et:shut-rd)
 396                    (:write et:shut-wr)
 397                    (:read-write et:shut-rdwr))))
 398   (values socket))
 399
 400 (defmethod shutdown ((socket passive-socket) direction)
 401   (declare (ignore direction))
 402   (error "You cannot shut down passive sockets."))
 403
 404
 405 ;;;;;;;;;;;;
 406 ;;  SEND  ;;
 407 ;;;;;;;;;;;;
 408
 409 (defun %normalize-send-buffer (buff start end ef)
 410   (setf (values start end) (%check-bounds buff start end))
 411   (etypecase buff
 412     (ub8-sarray (values buff start (- end start)))
 413     (ub8-vector (values (coerce buff 'ub8-sarray)
 414                         start (- end start)))
 415     (string     (values (%to-octets buff ef start end)
 416                         0 (- end start)))))
 417
 418 (defmethod socket-send ((buffer array)
 419                         (socket active-socket) &key (start 0) end
 420                         remote-address remote-port end-of-record
 421                         dont-route dont-wait no-signal
 422                         out-of-band #+linux more #+linux confirm)
 423   (check-type start unsigned-byte
 424               "a non-negative unsigned integer")
 425   (check-type end (or unsigned-byte null)
 426               "a non-negative unsigned integer or NIL")
 427   (when (or remote-port remote-address)
 428     (check-type remote-address sockaddr "a network address")
 429     (check-type remote-port (unsigned-byte 16) "a valid IP port number"))
 430   (let ((flags (logior (if end-of-record et:msg-eor 0)
 431                        (if dont-route et:msg-dontroute 0)
 432                        (if dont-wait  et:msg-dontwait 0)
 433                        (if no-signal  et:msg-nosignal 0)
 434                        (if out-of-band et:msg-oob 0)
 435                        #+linux (if more et:msg-more 0)
 436                        #+linux (if confirm et:msg-confirm 0))))
 437     (when (and (ipv4-address-p remote-address)
 438                (eql (socket-family socket) :ipv6))
 439       (setf remote-address (map-ipv4-address->ipv6 remote-address)))
 440     (multiple-value-bind (buff start-offset bufflen)
 441         (%normalize-send-buffer buffer start end (external-format-of socket))
 442       (with-foreign-object (ss 'et:sockaddr-storage)
 443         (et:bzero ss et:size-of-sockaddr-storage)
 444         (when remote-address
 445           (sockaddr->sockaddr-storage ss remote-address remote-port))
 446         (with-pointer-to-vector-data (buff-sap buff)
 447           (incf-pointer buff-sap start-offset)
 448           (with-socket-error-filter
 449             (return-from socket-send
 450               (et:sendto (fd-of socket)
 451                          buff-sap bufflen
 452                          flags
 453                          (if remote-address ss (null-pointer))
 454                          (if remote-address et:size-of-sockaddr-storage 0)))))))))
 455
 456 (defmethod socket-send (buffer (socket passive-socket) &key)
 457   (declare (ignore buffer))
 458   (error "You cannot send data on a passive socket."))
 459
 460
 461 ;;;;;;;;;;;;
 462 ;;  RECV  ;;
 463 ;;;;;;;;;;;;
 464
 465 (defun %normalize-receive-buffer (buff start end)
 466   (setf (values start end) (%check-bounds buff start end))
 467   (etypecase buff
 468     ((simple-array ub8 (*)) (values buff start (- end start)))))
 469
 470 (defun calc-recvfrom-flags (out-of-band peek wait-all dont-wait no-signal)
 471   (logior (if out-of-band et:msg-oob 0)
 472           (if peek        et:msg-peek 0)
 473           (if wait-all    et:msg-waitall 0)
 474           (if dont-wait   et:msg-dontwait 0)
 475           (if no-signal   et:msg-nosignal 0)))
 476
 477 (defun %do-recvfrom (buffer ss fd flags start end)
 478   (multiple-value-bind (buff start-offset bufflen)
 479       (%normalize-receive-buffer buffer start end)
 480     (with-socklen (size et:size-of-sockaddr-storage)
 481       (et:bzero ss et:size-of-sockaddr-storage)
 482       (with-pointer-to-vector-data (buff-sap buff)
 483         (incf-pointer buff-sap start-offset)
 484         (with-socket-error-filter
 485           (return-from %do-recvfrom
 486             (et:recvfrom fd buff-sap bufflen flags ss size)))))))
 487
 488 (defmethod socket-receive ((buffer array) (socket stream-socket) &key (start 0) end
 489                            out-of-band peek wait-all dont-wait no-signal)
 490   (with-foreign-object (ss 'et:sockaddr-storage)
 491     (let* ((flags (calc-recvfrom-flags out-of-band peek wait-all dont-wait no-signal))
 492            (bytes-received (%do-recvfrom buffer ss (fd-of socket) flags start end)))
 493       (values buffer bytes-received))))
 494
 495 (defmethod socket-receive ((buffer array) (socket datagram-socket) &key (start 0) end
 496                            out-of-band peek wait-all dont-wait no-signal)
 497   (with-foreign-object (ss 'et:sockaddr-storage)
 498     (let* ((flags (calc-recvfrom-flags out-of-band peek wait-all dont-wait no-signal))
 499            (bytes-received (%do-recvfrom buffer ss (fd-of socket) flags start end)))
 500       (multiple-value-bind (remote-address remote-port)
 501           (sockaddr-storage->sockaddr ss)
 502         (values buffer bytes-received remote-address remote-port)))))
 503
 504 (defmethod socket-receive (buffer (socket passive-socket) &key)
 505   (declare (ignore buffer))
 506   (error "You cannot receive data from a passive socket."))
 507
 508
 509 ;;
 510 ;; Only for datagram sockets
 511 ;;
 512
 513 (defmethod disconnect :before ((socket active-socket))
 514   (unless (typep socket 'datagram-socket)
 515     (error "You can only disconnect active datagram sockets.")))
 516
 517 (defmethod disconnect ((socket datagram-socket))
 518   (with-foreign-object (sin 'et:sockaddr-in)
 519     (et:bzero sin et:size-of-sockaddr-in)
 520     (setf (foreign-slot-value sin 'et:sockaddr-in 'et:addr) et:af-unspec)
 521     (with-socket-error-filter
 522       (et:connect (fd-of socket) sin et:size-of-sockaddr-in))))