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     ((:local :stream   :active  :default) . socket-stream-local-active)
  33     ((:local :stream   :passive :default) . socket-stream-local-passive)
  34     ((:local :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 ;;;;;;;;;;;;;;;;;;;;;;;;;
  45 ;;  SHARED-INITIALIZE  ;;
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;
  47
  48 (defun translate-make-socket-keywords-to-constants (family type protocol)
  49   (let ((sf (ecase family
  50               (:ipv4  et:af-inet)
  51               (:ipv6  et:af-inet6)
  52               (:local et:af-local)))
  53         (st (ecase type
  54               (:stream   et:sock-stream)
  55               (:datagram et:sock-dgram)))
  56         (sp (cond
  57               ((integerp protocol) protocol)
  58               ((eql protocol :default) 0)
  59               ((keywordp protocol)
  60                (protocol-number
  61                 (get-protocol-by-name (string-downcase
  62                                        (string protocol))))))))
  63     (values sf st sp)))
  64
  65 (defmethod shared-initialize :after ((socket socket) slot-names
  66                                      &key file-descriptor family
  67                                      type (protocol :default))
  68   (when (socket-open-p socket)
  69     (socket-close socket))
  70   (with-slots (fd (fam family) (proto protocol)) socket
  71     (multiple-value-bind (sf st sp)
  72         (translate-make-socket-keywords-to-constants family type protocol)
  73       (if file-descriptor
  74           (setf fd file-descriptor)
  75           (setf fd (with-socket-error-filter
  76                      (et:socket sf st sp))))
  77       (setf fam family)
  78       (setf proto protocol)
  79       (iomux:finalize-object-closing-fd socket fd))))
  80
  81 ;; TODO: find out how to make an FD-STREAM on other implementations
  82 (defun make-fd-stream (fd)
  83   (check-type fd unsigned-byte)
  84   #+sbcl
  85   (sb-sys:make-fd-stream fd
  86                          :name (format nil "Socket stream, fd: ~A" fd)
  87                          :input t :output t :buffering :full :dual-channel-p t
  88                          :element-type :default :auto-close nil)
  89   #+cmucl
  90   (system:make-fd-stream fd
  91                          :name (format nil "Socket stream, fd: ~A" fd)
  92                          :input t :output t :buffering :full
  93                          :binary-stream-p nil :auto-close nil))
  94
  95 (defmethod shared-initialize :after ((socket stream-socket) slot-names &key)
  96   (setf (slot-value socket 'lisp-stream)
  97         (make-fd-stream (socket-fd socket))))
  98
  99 (defmethod socket-type ((socket stream-socket))
 100   :stream)
 101
 102 (defmethod socket-type ((socket datagram-socket))
 103   :datagram)
 104
 105
 106 ;;;;;;;;;;;;;;;;;;;;
 107 ;;  PRINT-OBJECT  ;;
 108 ;;;;;;;;;;;;;;;;;;;;
 109
 110 (defmethod print-object ((socket socket-stream-internet-active) stream)
 111   (print-unreadable-object (socket stream :type nil :identity t)
 112     (format stream "internet stream socket" )
 113     (if (socket-connected-p socket)
 114         (format stream " connected to ~A/~A"
 115                 (netaddr->presentation (socket-address socket))
 116                 (socket-port socket))
 117         (if (slot-boundp socket 'fd)
 118             (format stream ", unconnected")
 119             (format stream ", closed")))))
 120
 121 (defmethod print-object ((socket socket-stream-internet-passive) stream)
 122   (print-unreadable-object (socket stream :type nil :identity t)
 123     (format stream "internet stream socket" )
 124     (if (socket-bound-p socket)
 125         (format stream " ~A ~A/~A"
 126                 (if (socket-listening-p socket)
 127                     "waiting for connections @"
 128                     "bound to")
 129                 (netaddr->presentation (socket-address socket))
 130                 (socket-port socket))
 131         (if (slot-boundp socket 'fd)
 132             (format stream ", unbound")
 133             (format stream ", closed")))))
 134
 135 (defmethod print-object ((socket socket-stream-local-active) stream)
 136   (print-unreadable-object (socket stream :type nil :identity t)
 137     (format stream "local stream socket" )
 138     (if (socket-connected-p socket)
 139         (format stream " connected to ~S"
 140                 (netaddr->presentation (socket-address socket)))
 141         (if (slot-boundp socket 'fd)
 142             (format stream ", unconnected")
 143             (format stream ", closed")))))
 144
 145 (defmethod print-object ((socket socket-stream-local-passive) stream)
 146   (print-unreadable-object (socket stream :type nil :identity t)
 147     (format stream "local stream socket" )
 148     (if (socket-bound-p socket)
 149         (format stream " ~A ~A"
 150                 (if (socket-listening-p socket)
 151                     "waiting for connections @"
 152                     "bound to")
 153                 (netaddr->presentation (socket-address socket)))
 154         (if (slot-boundp socket 'fd)
 155             (format stream ", unbound")
 156             (format stream ", closed")))))
 157
 158 (defmethod print-object ((socket socket-datagram-local-active) stream)
 159   (print-unreadable-object (socket stream :type nil :identity t)
 160     (format stream "local datagram socket" )
 161     (if (socket-connected-p socket)
 162         (format stream " connected to ~S"
 163                 (netaddr->presentation (socket-address socket)))
 164         (if (slot-boundp socket 'fd)
 165             (format stream ", unconnected")
 166             (format stream ", closed")))))
 167
 168 (defmethod print-object ((socket socket-datagram-internet-active) stream)
 169   (print-unreadable-object (socket stream :type nil :identity t)
 170     (format stream "internet stream socket" )
 171     (if (socket-connected-p socket)
 172         (format stream " connected to ~A/~A"
 173                 (netaddr->presentation (socket-address socket))
 174                 (socket-port socket))
 175         (if (slot-boundp socket 'fd)
 176             (format stream ", unconnected")
 177             (format stream ", closed")))))
 178
 179
 180 ;;;;;;;;;;;;;
 181 ;;  CLOSE  ;;
 182 ;;;;;;;;;;;;;
 183
 184 (defmethod socket-close progn ((socket socket))
 185   (cancel-finalization socket)
 186   (when (slot-boundp socket 'fd)
 187     (with-socket-error-filter
 188       (et:close (socket-fd socket))))
 189   (mapc #'(lambda (slot)
 190             (slot-makunbound socket slot))
 191         '(fd family protocol))
 192   (values socket))
 193
 194 (defmethod socket-close progn ((socket stream-socket))
 195   (slot-makunbound socket 'lisp-stream))
 196
 197 (defmethod socket-close progn ((socket passive-socket))
 198   (slot-makunbound socket 'listening))
 199
 200 (defmethod socket-open-p ((socket socket))
 201   (unless (slot-boundp socket 'fd)
 202     (return-from socket-open-p nil))
 203   (with-socket-error-filter
 204     (handler-case
 205         (with-foreign-object (ss 'et:sockaddr-storage)
 206           (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 207           (with-foreign-pointer (size #.(foreign-type-size :socklen))
 208             (setf (mem-ref size :socklen)
 209                   #.(foreign-type-size 'et:sockaddr-storage))
 210             (et:getsockname (socket-fd socket)
 211                             ss size)
 212             t))
 213       (unix-error (err)
 214         (case (error-identifier err)
 215           ((:ebadf
 216             #+freebsd :econnreset)
 217            nil)
 218           ;; some other error
 219           (otherwise (error err)))))))
 220
 221
 222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 223 ;;  get and set O_NONBLOCK  ;;
 224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 225
 226 (defmethod socket-non-blocking-mode ((socket socket))
 227   (with-slots (fd) socket
 228     (let ((file-flags (with-socket-error-filter
 229                         (et:fcntl fd et:f-getfl))))
 230       (not (zerop (logand file-flags et:o-nonblock)))))
 231   (values socket))
 232
 233 (defmethod (setf socket-non-blocking-mode) (value (socket socket))
 234   (check-type value boolean "a boolean value")
 235   (with-slots (fd) socket
 236     (let ((file-flags (et:fcntl fd et:f-getfl)))
 237       (with-socket-error-filter
 238         (et:fcntl fd et:f-setfl
 239                   (logior file-flags
 240                           (if value et:o-nonblock 0))))))
 241   (values value))
 242
 243
 244 ;;;;;;;;;;;;;;;;;;;
 245 ;;  GETSOCKNAME  ;;
 246 ;;;;;;;;;;;;;;;;;;;
 247
 248 (defmethod local-name ((socket internet-socket))
 249   (with-foreign-object (ss 'et:sockaddr-storage)
 250     (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 251     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 252       (setf (mem-ref size :socklen)
 253             #.(foreign-type-size 'et:sockaddr-storage))
 254      (with-socket-error-filter
 255        (et:getsockname (socket-fd socket)
 256                        ss size))
 257      (return-from local-name
 258        (sockaddr-storage->netaddr ss)))))
 259
 260 (defmethod local-name ((socket local-socket))
 261   (with-foreign-object (sun 'et:sockaddr-un)
 262     (et:memset sun 0 #.(foreign-type-size 'et:sockaddr-un))
 263     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 264       (setf (mem-ref size :socklen)
 265             #.(foreign-type-size 'et:sockaddr-storage))
 266       (with-socket-error-filter
 267         (et:getsockname (socket-fd socket)
 268                         sun size))
 269       (return-from local-name
 270         (sockaddr-un->netaddr sun)))))
 271
 272 (defmethod socket-address ((socket socket))
 273   (nth-value 0 (local-name socket)))
 274
 275 (defmethod socket-port ((socket internet-socket))
 276   (nth-value 1 (local-name socket)))
 277
 278
 279 ;;;;;;;;;;;;;;;;;;;
 280 ;;  GETPEERNAME  ;;
 281 ;;;;;;;;;;;;;;;;;;;
 282
 283 (defmethod remote-name ((socket internet-socket))
 284   (with-foreign-object (ss 'et:sockaddr-storage)
 285     (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 286     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 287       (setf (mem-ref size :socklen)
 288             #.(foreign-type-size 'et:sockaddr-storage))
 289       (with-socket-error-filter
 290         (et:getpeername (socket-fd socket)
 291                         ss size))
 292       (return-from remote-name
 293         (sockaddr-storage->netaddr ss)))))
 294
 295 (defmethod remote-name ((socket local-socket))
 296   (with-foreign-object (sun 'et:sockaddr-un)
 297     (et:memset sun 0 #.(foreign-type-size 'et:sockaddr-un))
 298     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 299       (setf (mem-ref size :socklen)
 300             #.(foreign-type-size 'et:sockaddr-storage))
 301       (with-socket-error-filter
 302         (et:getpeername (socket-fd socket)
 303                         sun size))
 304       (return-from remote-name
 305         (sockaddr-un->netaddr sun)))))
 306
 307
 308 ;;;;;;;;;;;;
 309 ;;  BIND  ;;
 310 ;;;;;;;;;;;;
 311
 312 (defmethod bind-address :before ((socket internet-socket)
 313                                  address &key (reuse-address t))
 314   (when reuse-address
 315     (set-socket-option socket :reuse-address :value t)))
 316
 317 (defun bind-ipv4-address (fd address port)
 318   (with-foreign-object (sin 'et:sockaddr-in)
 319     (make-sockaddr-in sin address port)
 320     (with-socket-error-filter
 321       (et:bind fd sin
 322                #.(foreign-type-size 'et:sockaddr-in)))))
 323
 324 (defun bind-ipv6-address (fd address port)
 325   (with-foreign-object (sin6 'et:sockaddr-in6)
 326     (make-sockaddr-in6 sin6 address port)
 327     (with-socket-error-filter
 328       (et:bind fd sin6
 329                #.(foreign-type-size 'et:sockaddr-in6)))))
 330
 331 (defmethod bind-address ((socket internet-socket)
 332                          (address ipv4addr)
 333                          &key (port 0))
 334   (if (eql (socket-family socket) :ipv6)
 335       (bind-ipv6-address (socket-fd socket)
 336                          (map-ipv4-vector-to-ipv6 (name address))
 337                          port)
 338       (bind-ipv4-address (socket-fd socket) (name address) port))
 339   (values socket))
 340
 341 (defmethod bind-address ((socket internet-socket)
 342                          (address ipv6addr)
 343                          &key (port 0))
 344   (bind-ipv6-address (socket-fd socket) (name address) port)
 345   (values socket))
 346
 347 (defmethod bind-address :before ((socket local-socket)
 348                                  (address localaddr) &key)
 349   (when (typep socket 'active-socket)
 350     (error "You can't bind an active Unix socket.")))
 351
 352 (defmethod bind-address ((socket local-socket)
 353                          (address localaddr) &key)
 354   (with-foreign-object (sun 'et:sockaddr-un)
 355     (make-sockaddr-un sun (name address))
 356     (with-socket-error-filter
 357       (et:bind (socket-fd socket)
 358                sun
 359                #.(foreign-type-size 'et:sockaddr-un))))
 360   (values socket))
 361
 362 (defmethod bind-address :after ((socket socket)
 363                                 (address netaddr) &key)
 364   (setf (slot-value socket 'bound) t))
 365
 366
 367 ;;;;;;;;;;;;;;
 368 ;;  LISTEN  ;;
 369 ;;;;;;;;;;;;;;
 370
 371 (defmethod socket-listen ((socket passive-socket)
 372                           &key (backlog (min *default-backlog-size*
 373                                              +max-backlog-size+)))
 374   (check-type backlog unsigned-byte "a non-negative integer")
 375   (with-socket-error-filter
 376     (et:listen (socket-fd socket) backlog))
 377   (setf (slot-value socket 'listening) t)
 378   (values socket))
 379
 380 (defmethod socket-listen ((socket active-socket)
 381                           &key backlog)
 382   (declare (ignore backlog))
 383   (error "You can't listen on active sockets."))
 384
 385
 386 ;;;;;;;;;;;;;;
 387 ;;  ACCEPT  ;;
 388 ;;;;;;;;;;;;;;
 389
 390 (defmethod accept-connection ((socket active-socket)
 391                               &key wait)
 392   (declare (ignore wait))
 393   (error "You can't accept connections on active sockets."))
 394
 395 (defmethod accept-connection ((socket passive-socket)
 396                               &key (wait t))
 397   (with-foreign-object (ss 'et:sockaddr-storage)
 398     (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 399     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 400       (setf (mem-ref size :socklen)
 401             #.(foreign-type-size 'et:sockaddr-storage))
 402       (let (non-blocking-state
 403             client-fd)
 404         (with-socket-error-filter
 405           (handler-case
 406               (if wait
 407                   ;; do a "normal" accept
 408                   ;; Note: the socket may already be in non-blocking mode
 409                   (setf client-fd (et:accept (socket-fd socket)
 410                                              ss size))
 411                   ;; set the socket to non-blocking mode before calling accept()
 412                   ;; if there's no new connection return NIL
 413                   (unwind-protect
 414                        (progn
 415                          ;; saving the current non-blocking state
 416                          (setf non-blocking-state (socket-non-blocking-mode socket))
 417                          ;; switch the socket to non-blocking mode
 418                          (setf (socket-non-blocking-mode socket) t)
 419                          (setf client-fd (et:accept (socket-fd socket)
 420                                                     ss size)))
 421                     ;; restoring the socket's non-blocking state
 422                     (setf (socket-non-blocking-mode socket) non-blocking-state)))
 423             ;; the socket is marked non-blocking and there's no new connection
 424             (et:unix-error-wouldblock (err)
 425               (declare (ignore err))
 426               (return-from accept-connection nil))))
 427
 428         (let ((client-socket
 429                ;; create the client socket object
 430                (make-instance (active-class socket)
 431                               :file-descriptor client-fd)))
 432           (return-from accept-connection client-socket))))))
 433
 434
 435 ;;;;;;;;;;;;;;;
 436 ;;  CONNECT  ;;
 437 ;;;;;;;;;;;;;;;
 438
 439 #+freebsd
 440 (defmethod connect :before ((socket active-socket)
 441                             netaddr &key)
 442   (when *no-sigpipe*
 443     (set-socket-option socket :no-sigpipe :value t)))
 444
 445 (defun ipv4-connect (fd address port)
 446   (with-foreign-object (sin 'et:sockaddr-in)
 447     (make-sockaddr-in sin address port)
 448     (with-socket-error-filter
 449       (et:connect fd sin
 450                   #.(foreign-type-size 'et:sockaddr-in)))))
 451
 452 (defun ipv6-connect (fd address port)
 453   (with-foreign-object (sin6 'et:sockaddr-in6)
 454     (make-sockaddr-in6 sin6 address port)
 455     (with-socket-error-filter
 456       (et:connect fd sin6
 457                   (foreign-type-size 'et:sockaddr-in6)))))
 458
 459 (defmethod connect ((socket internet-socket)
 460                     (address ipv4addr) &key (port 0))
 461   (if (eql (socket-family socket) :ipv6)
 462       (ipv6-connect (socket-fd socket)
 463                     (map-ipv4-vector-to-ipv6 (name address))
 464                     port)
 465       (ipv4-connect (socket-fd socket) (name address) port))
 466   (values socket))
 467
 468 (defmethod connect ((socket internet-socket)
 469                     (address ipv6addr) &key (port 0))
 470   (ipv6-connect (socket-fd socket) (name address) port)
 471   (values socket))
 472
 473 (defmethod connect ((socket local-socket)
 474                     (address localaddr) &key)
 475   (with-foreign-object (sun 'et:sockaddr-un)
 476     (make-sockaddr-un sun (name address))
 477     (with-socket-error-filter
 478       (et:connect (socket-fd socket)
 479                   sun
 480                   #.(foreign-type-size 'et:sockaddr-un))))
 481   (values socket))
 482
 483 (defmethod connect ((socket passive-socket)
 484                     address &key)
 485   (error "You cannot connect passive sockets."))
 486
 487 (defmethod socket-connected-p ((socket socket))
 488   (unless (slot-boundp socket 'fd)
 489     (return-from socket-connected-p nil))
 490   (with-socket-error-filter
 491     (handler-case
 492         (with-foreign-object (ss 'et:sockaddr-storage)
 493           (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 494           (with-foreign-pointer (size #.(foreign-type-size :socklen))
 495             (setf (mem-ref size :socklen)
 496                   #.(foreign-type-size 'et:sockaddr-storage))
 497             (et:getpeername (socket-fd socket)
 498                             ss size)
 499             t))
 500       (et:unix-error-notconn (err)
 501         (declare (ignore err))
 502         nil))))
 503
 504
 505 ;;;;;;;;;;;;;;;;
 506 ;;  SHUTDOWN  ;;
 507 ;;;;;;;;;;;;;;;;
 508
 509 (defmethod shutdown ((socket active-socket) direction)
 510   (check-type direction (member :read :write :read-write)
 511               "valid shutdown specifier")
 512   (with-socket-error-filter
 513     (et:shutdown (socket-fd socket)
 514                  (ecase direction
 515                    (:read et:shut-rd)
 516                    (:write et:shut-wr)
 517                    (:read-write et:shut-rdwr))))
 518   (values socket))
 519
 520 (defmethod shutdown ((socket passive-socket) direction)
 521   (error "You cannot shut down passive sockets."))
 522
 523
 524 ;;;;;;;;;;;;
 525 ;;  SEND  ;;
 526 ;;;;;;;;;;;;
 527
 528 (defun normalize-send-buffer (buff vstart vend)
 529   (let ((start (or vstart 0))
 530         (end (if vend
 531                  (min vend (length buff))
 532                  (length buff))))
 533     (assert (<= start end))
 534     (etypecase buff
 535       ((simple-array ub8 (*)) (values buff start (- end start)))
 536       ((vector ub8) (values (coerce buff '(simple-array ub8 (*)))
 537                             start (- end start)))
 538       (string (values (coerce (flexi-streams:string-to-octets buff :external-format :latin1
 539                                                               :start start :end end)
 540                               '(simple-array ub8 (*)))
 541                       0 (- end start))))))
 542
 543 (defmethod socket-send :before ((buffer array)
 544                                 (socket active-socket)
 545                                 &key start end
 546                                 remote-address remote-port)
 547   (check-type start (or unsigned-byte null)
 548               "a non-negative value or NIL")
 549   (check-type end (or unsigned-byte null)
 550               "a non-negative value or NIL")
 551   (when (or remote-port remote-address)
 552     (check-type remote-address netaddr "a network address")
 553     (check-type remote-port (unsigned-byte 16) "a valid IP port number")))
 554
 555 (defmethod socket-send ((buffer array)
 556                         (socket active-socket) &key start end
 557                         remote-address remote-port end-of-record
 558                         dont-route dont-wait (no-signal *no-sigpipe*)
 559                         out-of-band #+linux more #+linux confirm)
 560
 561   (let ((flags (logior (if end-of-record et:msg-eor 0)
 562                        (if dont-route et:msg-dontroute 0)
 563                        (if dont-wait  et:msg-dontwait 0)
 564                        (if no-signal  et:msg-nosignal 0)
 565                        (if out-of-band et:msg-oob 0)
 566                        #+linux (if more et:msg-more 0)
 567                        #+linux (if confirm et:msg-confirm 0))))
 568
 569     (when (and (ipv4-address-p remote-address)
 570                (eql (socket-family socket) :ipv6))
 571       (setf remote-address (map-ipv4-address->ipv6 remote-address)))
 572     (multiple-value-bind (buff start-offset bufflen)
 573         (normalize-send-buffer buffer start end)
 574       (with-foreign-object (ss 'et:sockaddr-storage)
 575         (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 576         (when remote-address
 577           (netaddr->sockaddr-storage ss remote-address remote-port))
 578         (with-pointer-to-vector-data (buff-sap buff)
 579           (incf-pointer buff-sap start-offset)
 580           (with-socket-error-filter
 581             (return-from socket-send
 582               (et:sendto (socket-fd socket)
 583                          buff-sap bufflen
 584                          flags
 585                          (if remote-address ss (null-pointer))
 586                          (if remote-address #.(foreign-type-size 'et:sockaddr-storage) 0)))))))))
 587
 588 (defmethod socket-send (buffer (socket passive-socket) &key)
 589   (error "You cannot send data on a passive socket."))
 590
 591
 592 ;;;;;;;;;;;;
 593 ;;  RECV  ;;
 594 ;;;;;;;;;;;;
 595
 596 (defun normalize-receive-buffer (buff vstart vend)
 597   (let ((start (or vstart 0))
 598         (end (if vend
 599                  (min vend (length buff))
 600                  (length buff))))
 601     (assert (<= start end))
 602     (etypecase buff
 603       ((simple-array ub8 (*)) (values buff start (- end start)))
 604       (simple-base-string (values buff start (- end start))))))
 605
 606 (defmethod socket-receive :before ((buffer array)
 607                                    (socket active-socket)
 608                                    &key start end)
 609   (check-type start (or unsigned-byte null)
 610               "a non-negative value or NIL")
 611   (check-type end (or unsigned-byte null)
 612               "a non-negative value or NIL"))
 613
 614 (defmethod socket-receive ((buffer array)
 615                            (socket active-socket) &key start end
 616                            out-of-band peek wait-all
 617                            dont-wait (no-signal *no-sigpipe*))
 618
 619   (let ((flags (logior (if out-of-band et:msg-oob 0)
 620                        (if peek        et:msg-peek 0)
 621                        (if wait-all    et:msg-waitall 0)
 622                        (if dont-wait   et:msg-dontwait 0)
 623                        (if no-signal   et:msg-nosignal 0)))
 624         bytes-received)
 625
 626     (multiple-value-bind (buff start-offset bufflen)
 627         (normalize-receive-buffer buffer start end)
 628       (with-foreign-object (ss 'et:sockaddr-storage)
 629         (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 630         (with-foreign-pointer (size #.(foreign-type-size :socklen))
 631           (setf (mem-ref size :socklen)
 632                 #.(foreign-type-size 'et:sockaddr-storage))
 633           (with-pointer-to-vector-data (buff-sap buff)
 634             (incf-pointer buff-sap start-offset)
 635             (with-socket-error-filter
 636               (setf bytes-received
 637                     (et:recvfrom (socket-fd socket)
 638                                  buff-sap bufflen
 639                                  flags
 640                                  ss size)))))
 641
 642         (return-from socket-receive
 643           ;; when socket is a datagram socket
 644           ;; return the sender's address as 3rd value
 645           (if (typep socket 'datagram-socket)
 646               (multiple-value-bind (remote-address remote-port)
 647                   (sockaddr-storage->netaddr ss)
 648                 (values buffer bytes-received remote-address remote-port))
 649               (values buffer bytes-received)))))))
 650
 651 (defmethod socket-receive (buffer (socket passive-socket) &key)
 652   (error "You cannot receive data from a passive socket."))
 653
 654
 655 ;;
 656 ;; Only for datagram sockets
 657 ;;
 658
 659 (defmethod unconnect :before ((socket active-socket))
 660   (unless (typep socket 'datagram-socket)
 661     (error "You can only unconnect active datagram sockets.")))
 662
 663 (defmethod unconnect ((socket datagram-socket))
 664   (with-socket-error-filter
 665     (with-foreign-object (sin 'et:sockaddr-in)
 666       (et:memset sin 0 #.(foreign-type-size 'et:sockaddr-in))
 667       (setf (foreign-slot-value sin 'et:sockaddr-in 'et:address) et:af-unspec)
 668       (et:connect (socket-fd socket)
 669                   sin
 670                   #.(foreign-type-size 'et:sockaddr-in)))))