sockets/socket-methods.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006 by Stelian Ionescu                                 ;
   5 ;                                                                         ;
   6 ;   This program is free software; you can redistribute it and/or modify  ;
   7 ;   it under the terms of the GNU General Public License as published by  ;
   8 ;   the Free Software Foundation; either version 2 of the License, or     ;
   9 ;   (at your option) any later version.                                   ;
  10 ;                                                                         ;
  11 ;   This program is distributed in the hope that it will be useful,       ;
  12 ;   but WITHOUT ANY WARRANTY; without even the implied warranty of        ;
  13 ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         ;
  14 ;   GNU General Public License for more details.                          ;
  15 ;                                                                         ;
  16 ;   You should have received a copy of the GNU General Public License     ;
  17 ;   along with this program; if not, write to the                         ;
  18 ;   Free Software Foundation, Inc.,                                       ;
  19 ;   51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA              ;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 ;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2)))
  23 (declaim (optimize (speed 0) (safety 2) (space 0) (debug 2)))
  24
  25 (in-package #:net.sockets)
  26
  27 (defparameter *socket-type-map*
  28   '(((:ipv4 :stream   :active  :default) . socket-stream-internet-active)
  29     ((:ipv6 :stream   :active  :default) . socket-stream-internet-active)
  30     ((:ipv4 :stream   :passive :default) . socket-stream-internet-passive)
  31     ((:ipv6 :stream   :passive :default) . socket-stream-internet-passive)
  32     ((:unix :stream   :active  :default) . socket-stream-local-active)
  33     ((:unix :stream   :passive :default) . socket-stream-local-passive)
  34     ((:unix :datagram :active  :default) . socket-datagram-local-active)
  35     ((:ipv4 :datagram :active  :default) . socket-datagram-internet-active)
  36     ((:ipv6 :datagram :active  :default) . socket-datagram-internet-active)))
  37
  38 (defun select-socket-type (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 ;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;  SHARED-INITIALIZE  ;;
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;
  46
  47 (defun translate-make-socket-keywords-to-constants (family type protocol)
  48   (let ((sf (ecase family
  49               (:ipv4  et:af-inet)
  50               (:ipv6  et:af-inet6)
  51               (:local et:af-local)))
  52         (st (ecase type
  53               (:stream   et:sock-stream)
  54               (:datagram et:sock-dgram)))
  55         (sp (cond
  56               ((integerp protocol) protocol)
  57               ((eql protocol :default) 0)
  58               ((keywordp protocol)
  59                (protocol-number
  60                 (get-protocol-by-name (string-downcase
  61                                        (string protocol))))))))
  62     (values sf st sp)))
  63
  64 (defun set-finalizer-on-socket (socket fd)
  65   (sb-ext:finalize socket #'(lambda () (et:close fd))))
  66
  67 (defmethod shared-initialize :after ((socket socket) slot-names
  68                                      &key file-descriptor family
  69                                      type (protocol :default))
  70   (when (socket-open-p socket)
  71     (socket-close socket))
  72   (with-slots (fd (fam family) (proto protocol)) socket
  73     (multiple-value-bind (sf st sp)
  74         (translate-make-socket-keywords-to-constants family type protocol)
  75       (if file-descriptor
  76           (setf fd file-descriptor)
  77           (setf fd (with-socket-error-filter
  78                      (et:socket sf st sp))))
  79       (setf fam family)
  80       (setf proto protocol)
  81       (set-finalizer-on-socket socket fd))))
  82
  83 (defmethod shared-initialize :after ((socket stream-socket) slot-names &key)
  84   (setf (slot-value socket 'lisp-stream)
  85         (sb-sys:make-fd-stream (socket-fd socket)
  86                                :name (format nil "Socket stream, fd: ~a" (socket-fd socket))
  87                                :input t :output t :buffering :none :dual-channel-p t
  88                                :element-type :default :auto-close nil)))
  89
  90 (defmethod socket-type ((socket stream-socket))
  91   :stream)
  92
  93 (defmethod socket-type ((socket datagram-socket))
  94   :datagram)
  95
  96 ;;;;;;;;;;;;;
  97 ;;  CLOSE  ;;
  98 ;;;;;;;;;;;;;
  99
 100 (defmethod socket-close progn ((socket socket))
 101   (when (slot-boundp socket 'fd)
 102     (with-socket-error-filter
 103       (et:close (socket-fd socket))))
 104   (sb-ext:cancel-finalization socket)
 105   (mapc #'(lambda (slot)
 106             (slot-makunbound socket slot))
 107         '(fd address family protocol))
 108   socket)
 109
 110 (defmethod socket-close progn ((socket stream-socket))
 111   (slot-makunbound socket 'lisp-stream))
 112
 113 (defmethod socket-close progn ((socket internet-socket))
 114   (slot-makunbound socket 'port))
 115
 116 (defmethod socket-open-p ((socket socket))
 117   (unless (slot-boundp socket 'fd)
 118     (return-from socket-open-p nil))
 119   (with-socket-error-filter
 120     (handler-case
 121         (with-pinned-aliens ((ss et:sockaddr-storage)
 122                              (size et:socklen-t
 123                                    #.et::size-of-sockaddr-storage))
 124           (let ((ssptr (addr ss)))
 125             (et:getsockname (socket-fd socket)
 126                             ssptr (addr size))
 127             t))
 128       (unix-error (err)
 129         (case (error-identifier err)
 130           ((:ebadf
 131             :enotsock
 132             :econnreset)
 133            nil)
 134           ;; some other error
 135           (otherwise (error err)))))))
 136
 137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 138 ;;  get and set O_NONBLOCK  ;;
 139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 140
 141 (defmethod socket-non-blocking-mode ((socket socket))
 142   (with-slots (fd) socket
 143     (let ((file-flags (with-socket-error-filter
 144                         (et:fcntl fd et:f-getfl))))
 145       (not (zerop (logand file-flags et:o-nonblock))))))
 146
 147 (defmethod (setf socket-non-blocking-mode) (value (socket socket))
 148   (check-type value boolean "a boolean value")
 149   (with-slots (fd) socket
 150     (let ((file-flags (et:fcntl fd et:f-getfl)))
 151       (with-socket-error-filter
 152         (et:fcntl fd et:f-setfl
 153                   (logior file-flags
 154                           (if value et:o-nonblock 0))))))
 155   value)
 156
 157 ;;;;;;;;;;;;;;;;;;;
 158 ;;  GETSOCKNAME  ;;
 159 ;;;;;;;;;;;;;;;;;;;
 160
 161 (defmethod local-name ((socket internet-socket))
 162   (with-pinned-aliens ((ss et:sockaddr-storage)
 163                        (size et:socklen-t
 164                              #.et::size-of-sockaddr-storage))
 165     (let ((ssptr (addr ss)))
 166       (with-socket-error-filter
 167         (et:getsockname (socket-fd socket)
 168                         ssptr (addr size)))
 169       (return-from local-name
 170         (values (sockaddr-storage->netaddr ssptr)
 171                 (ntohs (slot (cast ssptr (* et:sockaddr-in))
 172                              'et:port)))))))
 173 (defmethod local-name ((socket local-socket))
 174   (with-pinned-aliens ((sun et:sockaddr-un)
 175                        (size et:socklen-t
 176                              #.et::size-of-sockaddr-un))
 177     (let ((sunptr (addr sun)))
 178       (with-socket-error-filter
 179         (et:getsockname (socket-fd socket)
 180                         sunptr (addr size)))
 181       (return-from local-name
 182         (values (sockaddr-un->netaddr sunptr))))))
 183
 184 ;;;;;;;;;;;;;;;;;;;
 185 ;;  GETPEERNAME  ;;
 186 ;;;;;;;;;;;;;;;;;;;
 187
 188 (defmethod remote-name ((socket internet-socket))
 189   (with-pinned-aliens ((ss et:sockaddr-storage)
 190                        (size et:socklen-t
 191                              #.et::size-of-sockaddr-storage))
 192     (let ((ssptr (addr ss)))
 193       (with-socket-error-filter
 194         (et:getpeername (socket-fd socket)
 195                         ssptr (addr size)))
 196       (return-from remote-name
 197         (values (sockaddr-storage->netaddr ssptr)
 198                 (ntohs (slot (cast ssptr (* et:sockaddr-in))
 199                              'et:port)))))))
 200
 201 (defmethod remote-name ((socket local-socket))
 202   (with-pinned-aliens ((sun et:sockaddr-un)
 203                        (size et:socklen-t
 204                              #.et::size-of-sockaddr-un))
 205     (let ((sunptr (addr sun)))
 206       (with-socket-error-filter
 207         (et:getpeername (socket-fd socket)
 208                         sunptr (addr size)))
 209       (return-from remote-name
 210         (values (sockaddr-un->netaddr sunptr))))))
 211
 212 ;;;;;;;;;;;;
 213 ;;  BIND  ;;
 214 ;;;;;;;;;;;;
 215
 216 (defmethod bind-address :before ((socket internet-socket)
 217                                  address &key (reuse-address t))
 218   (when reuse-address
 219     (set-socket-option socket :reuse-address :value t)))
 220
 221 (defmethod bind-address ((socket internet-socket)
 222                          (address ipv4addr)
 223                          &key (port 0) interface)
 224   (with-pinned-aliens ((sin et:sockaddr-in))
 225     (make-sockaddr-in (addr sin) (name address) port)
 226     (with-socket-error-filter
 227       (et:bind (socket-fd socket)
 228                (addr sin)
 229                et::size-of-sockaddr-in)))
 230   (values))
 231
 232 (defmethod bind-address ((socket internet-socket)
 233                          (address ipv6addr)
 234                          &key (port 0) interface)
 235   (with-pinned-aliens ((sin6 et:sockaddr-in6))
 236     (make-sockaddr-in6 (addr sin6) (name address) port)
 237     (with-socket-error-filter
 238       (et:bind (socket-fd socket)
 239                (addr sin6)
 240                et::size-of-sockaddr-in6)))
 241   (values))
 242
 243 (defmethod bind-address :before ((socket local-socket)
 244                                  (address localaddr) &key)
 245   (when (typep socket 'active-socket)
 246     (error "You can't bind an active Unix socket.")))
 247
 248 (defmethod bind-address ((socket local-socket)
 249                          (address localaddr) &key)
 250   (with-pinned-aliens ((sun et:sockaddr-un))
 251     (make-sockaddr-un (addr sun) (name address))
 252     (with-socket-error-filter
 253       (et:bind (socket-fd socket)
 254                (addr sun)
 255                et::size-of-sockaddr-un)))
 256   (values))
 257
 258 (defmethod bind-address :after ((socket socket)
 259                                 (address netaddr) &key)
 260   (setf (slot-value socket 'address) (copy-netaddr address)))
 261
 262 (defmethod bind-address :after ((socket internet-socket)
 263                                 (address netaddr) &key port)
 264   (setf (slot-value socket 'port) port))
 265
 266
 267 ;;;;;;;;;;;;;;
 268 ;;  LISTEN  ;;
 269 ;;;;;;;;;;;;;;
 270
 271 (defmethod socket-listen ((socket passive-socket)
 272                           &key (backlog (min *default-backlog-size*
 273                                              +max-backlog-size+)))
 274   (check-type backlog unsigned-byte "a non-negative integer")
 275   (with-socket-error-filter
 276     (et:listen (socket-fd socket) backlog))
 277   (values))
 278
 279 (defmethod socket-listen ((socket active-socket)
 280                           &key backlog)
 281   (declare (ignore backlog))
 282   (error "You can't listen on active sockets."))
 283
 284 ;;;;;;;;;;;;;;
 285 ;;  ACCEPT  ;;
 286 ;;;;;;;;;;;;;;
 287
 288 (defmethod accept-connection ((socket active-socket)
 289                               &key wait)
 290   (declare (ignore wait))
 291   (error "You can't accept connections on active sockets."))
 292
 293 (defmethod accept-connection ((socket passive-socket)
 294                               &key (wait t))
 295   (with-pinned-aliens ((ss et:sockaddr-storage)
 296                        (size et:socklen-t
 297                              #.et::size-of-sockaddr-storage))
 298     (let (non-blocking-state
 299           client-fd)
 300       (with-socket-error-filter
 301         (handler-case
 302             (if wait
 303                 ;; do a "normal" accept
 304                 ;; Note: the socket may already be in non-blocking mode
 305                 (setf client-fd (et:accept (socket-fd socket)
 306                                            (addr ss) (addr size)))
 307                 ;; set the socket to non-blocking mode before calling accept()
 308                 ;; if there's no new connection return NIL
 309                 (unwind-protect
 310                      (progn
 311                        ;; saving the current non-blocking state
 312                        (setf non-blocking-state (socket-non-blocking-mode socket))
 313                        (setf client-fd (et:accept (socket-fd socket)
 314                                                   (addr ss) (addr size))))
 315                   ;; restoring the socket's non-blocking state
 316                   (setf (socket-non-blocking-mode socket) non-blocking-state)))
 317           ;; the socket is marked non-blocking and there's no new connection
 318           (et:unix-error-wouldblock (err)
 319             (declare (ignore err))
 320             (return-from accept-connection nil))))
 321
 322       (let ((client-socket
 323              ;; create the client socket object
 324              (make-instance (select-socket-type (socket-family   socket)
 325                                                 (socket-type     socket)
 326                                                 :active
 327                                                 (socket-protocol socket))
 328                             :file-descriptor client-fd)))
 329         ;; setting the socket's remote address and port
 330         (multiple-value-bind (remote-address remote-port)
 331             (remote-name client-socket)
 332           (setf (slot-value client-socket 'address) remote-address)
 333           ;; when it's an internet socket
 334           (when remote-port
 335             (setf (slot-value client-socket 'port) remote-port)))
 336         (return-from accept-connection client-socket)))))
 337
 338
 339 ;;;;;;;;;;;;;;;
 340 ;;  CONNECT  ;;
 341 ;;;;;;;;;;;;;;;
 342
 343 #+freebsd
 344 (defmethod connect :before ((socket active-socket)
 345                             netaddr &key)
 346   (when *no-sigpipe*
 347     (set-socket-option socket :no-sigpipe :value t)))
 348
 349 (defmethod connect ((socket internet-socket)
 350                     (address ipv4addr) &key (port 0))
 351   (with-pinned-aliens ((sin et:sockaddr-in))
 352     (make-sockaddr-in (addr sin) (name address) port)
 353     (with-socket-error-filter
 354       (et:connect (socket-fd socket)
 355                   (addr sin)
 356                   et::size-of-sockaddr-in))
 357     (setf (slot-value socket 'port) port))
 358   (values))
 359
 360 (defmethod connect ((socket internet-socket)
 361                     (address ipv6addr) &key (port 0))
 362   (with-pinned-aliens ((sin6 et:sockaddr-in6))
 363     (make-sockaddr-in6 (addr sin6) (name address) port)
 364     (with-socket-error-filter
 365       (et:connect (socket-fd socket)
 366                   (addr sin6)
 367                   et::size-of-sockaddr-in6))
 368     (setf (slot-value socket 'port) port))
 369   (values))
 370
 371 (defmethod connect ((socket local-socket)
 372                     (address localaddr) &key)
 373   (with-pinned-aliens ((sun et:sockaddr-un))
 374     (make-sockaddr-un (addr sun) (name address))
 375     (with-socket-error-filter
 376       (et:connect (socket-fd socket)
 377                   (addr sun)
 378                   et::size-of-sockaddr-un)))
 379   (values))
 380
 381 (defmethod connect :after ((socket active-socket)
 382                            (address netaddr) &key)
 383   (setf (slot-value socket 'address) (copy-netaddr address)))
 384
 385 (defmethod connect ((socket passive-socket)
 386                     address &key)
 387   (error "You cannot connect passive sockets."))
 388
 389 ;;;;;;;;;;;;;;;;
 390 ;;  SHUTDOWN  ;;
 391 ;;;;;;;;;;;;;;;;
 392
 393 (defmethod shutdown ((socket active-socket) direction)
 394   (check-type direction (member :read :write :read-write)
 395               "valid shutdown specifier")
 396   (with-socket-error-filter
 397     (et:shutdown (socket-fd socket)
 398                  (ecase direction
 399                    (:read et:shut-rd)
 400                    (:write et:shut-wr)
 401                    (:read-write et:shut-rdwr))))
 402   socket)
 403
 404 (defmethod shutdown ((socket passive-socket) direction)
 405   (error "You cannot shut down passive sockets."))
 406
 407 ;;;;;;;;;;;;
 408 ;;  SEND  ;;
 409 ;;;;;;;;;;;;
 410
 411 (defun normalize-send-buffer (buff length)
 412   (check-type length (or unsigned-byte null)
 413               "a non-negative value or NIL")
 414   (let ((end (if length
 415                  (min length (length buff))
 416                  (length buff))))
 417     (etypecase buff
 418       ((simple-array ub8 (*)) (values buff end))
 419       (simple-base-string (values buff end))
 420       (string (values (sb-ext:string-to-octets buff :end end)
 421                       end)))))
 422
 423 (defmethod socket-send ((buffer simple-array)
 424                         (socket active-socket) &key length
 425                         remote-address remote-port end-of-record
 426                         dont-route dont-wait (no-signal *no-sigpipe*)
 427                         out-of-band #+linux more #+linux confirm)
 428   (let ((flags (logior (if end-of-record et:msg-eor 0)
 429                        (if dont-route et:msg-dontroute 0)
 430                        (if dont-wait  et:msg-dontwait 0)
 431                        (if no-signal  et:msg-nosignal 0)
 432                        (if out-of-band et:msg-oob 0)
 433                        #+linux (if more et:msg-more 0)
 434                        #+linux (if confirm et:msg-confirm 0))))
 435     (multiple-value-bind (buff bufflen)
 436         (normalize-send-buffer buffer length)
 437       (with-alien ((ss et:sockaddr-storage))
 438         (when remote-address
 439           (netaddr->sockaddr-storage ss remote-address remote-port))
 440         (sb-sys:with-pinned-objects (buff ss)
 441           (with-socket-error-filter
 442             (return-from socket-send
 443               (et:sendto (socket-fd socket)
 444                          (sb-sys:vector-sap buff) bufflen
 445                          flags
 446                          (if remote-address (addr ss) nil)
 447                          (if remote-address et::size-of-sockaddr-storage 0)))))))))
 448
 449 (defmethod socket-send (buffer (socket passive-socket) &key)
 450   (error "You cannot send data on a passive socket."))
 451
 452 ;;;;;;;;;;;;
 453 ;;  RECV  ;;
 454 ;;;;;;;;;;;;
 455
 456 (defun normalize-receive-buffer (buff length)
 457   (check-type length (or unsigned-byte null)
 458               "a non-negative value or NIL")
 459   (let ((end (if length
 460                  (min length (length buff))
 461                  (length buff))))
 462     (etypecase buff
 463       ((simple-array ub8 (*)) (values buff end))
 464       (simple-base-string (values buff end)))))
 465
 466 (defmethod socket-receive ((buffer simple-array)
 467                            (socket active-socket) &key length
 468                            remote-address out-of-band peek wait-all
 469                            dont-wait trunc (no-signal *no-sigpipe*))
 470
 471   (check-type buffer (simple-array ub8 (*)))
 472   (check-type length (or unsigned-byte null)
 473               "a non-negative value or NIL")
 474
 475   (let ((flags (logior (if out-of-band et:msg-oob 0)
 476                        (if peek        et:msg-peek 0)
 477                        (if wait-all    et:msg-waitall 0)
 478                        (if dont-wait   et:msg-dontwait 0)
 479                        (if trunc       et:msg-trunc 0)
 480                        (if no-signal   et:msg-nosignal 0))))
 481     (multiple-value-bind (buff bufflen)
 482         (normalize-receive-buffer buffer length)
 483       (with-alien ((ss et:sockaddr-storage)
 484                    (size et:socklen-t #.et::size-of-sockaddr-storage))
 485         (when remote-address
 486           (netaddr->sockaddr-storage ss remote-address))
 487         (sb-sys:with-pinned-objects (buff ss size)
 488           (with-socket-error-filter
 489             (return-from socket-receive
 490               (et:recvfrom (socket-fd socket)
 491                            (sb-sys:vector-sap buff) bufflen
 492                            flags
 493                            (if remote-address (addr ss) nil)
 494                            (if remote-address (addr size) nil)))))))))
 495
 496 (defmethod socket-receive (buffer (socket passive-socket) &key)
 497   (error "You cannot receive data from a passive socket."))
 498
 499
 500 ;;
 501 ;; Only for datagram sockets
 502 ;;
 503
 504 (defmethod unconnect :before ((socket active-socket))
 505   (unless (typep socket 'datagram-socket)
 506     (error "You can only unconnect active datagram sockets.")))
 507
 508 (defmethod unconnect ((socket datagram-socket))
 509   (with-socket-error-filter
 510     (with-pinned-aliens ((sin et:sockaddr-in))
 511       (et:memset (addr sin) 0 et::size-of-sockaddr-in)
 512       (setf (slot sin 'et:address) et:af-unspec)
 513       (et:connect (socket-fd socket)
 514                   (addr sin)
 515                   et::size-of-sockaddr-in)
 516       (slot-makunbound socket 'address)
 517       (when (typep socket 'internet-socket)
 518         (slot-makunbound socket 'port)))))