contrib/sb-bsd-sockets/sockopt.lisp

   1 (in-package :sb-bsd-sockets)
   2
   3 #||
   4 <H2> Socket Options </h2>
   5 <a name="sockopt"> </a>
   6 <p> A subset of socket options are supported, using a fairly
   7 general framework which should make it simple to add more as required
   8 - see sockopt.lisp for details.  The name mapping from C is fairly
   9 straightforward: <tt>SO_RCVLOWAT</tt> becomes
  10 <tt>sockopt-receive-low-water</tt> and <tt>(setf
  11 sockopt-receive-low-water)</tt>.
  12 ||#
  13
  14 #|
  15 getsockopt(socket, level, int optname, void *optval, socklen_t *optlen)
  16 setsockopt(socket, level, int optname, void *optval, socklen_t optlen)
  17              ^ SOL_SOCKET or a protocol number
  18
  19 In terms of providing a useful interface, we have to face up to the
  20 fact that most of these take different data types - some are integers,
  21 some are booleans, some are foreign struct instances, etc etc
  22
  23  (define-socket-option lisp-name level number mangle-arg size mangle-return)
  24
  25 macro-expands to two functions that define lisp-name and (setf ,lisp-name)
  26 and calls the functions mangle-arg and mangle-return on outgoing and incoming
  27 data resp.
  28
  29 Parameters passed to the function thus defined (lisp-name)
  30 are all passed directly into mangle-arg.  mangle-arg should return an
  31 alien pointer  - this is passed unscathed to the foreign routine, so
  32 wants to have type (* t).  Note that even for options that have
  33 integer arguments, this is still a pointer to said integer.
  34
  35 size is the size of the buffer that the return of mangle-arg points
  36 to, and also of the buffer that we should allocate for getsockopt
  37 to write into.
  38
  39 mangle-return is called with an alien buffer and should turn it into
  40 something that the caller will want.
  41
  42 Code for options that not every system has should be conditionalised:
  43
  44  (if (boundp 'sockint::IP_RECVIF)
  45      (define-socket-option so-receive-interface (getprotobyname "ip")
  46        sockint::IP_RECVIF  ...  ))
  47
  48
  49 |#
  50
  51 (defmacro define-socket-option
  52   (lisp-name level number buffer-type mangle-arg mangle-return mangle-setf-buffer)
  53   (let ((find-level
  54          (if (numberp (eval level))
  55              level
  56              `(get-protocol-by-name ,(string-downcase (symbol-name level))))))
  57     `(progn
  58       (export ',lisp-name)
  59       (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket)))
  60         (sb-alien:with-alien ((size sb-alien:integer)
  61                               (buffer ,buffer-type))
  62           (setf size (sb-alien:alien-size ,buffer-type :bytes))
  63           (if (= -1 (sockint::getsockopt fd ,find-level ,number
  64                                          (sb-alien:addr buffer)
  65                                          (sb-alien:addr size)))
  66               (socket-error "getsockopt")
  67               (,mangle-return buffer size))))
  68       (defun (setf ,lisp-name) (new-val socket
  69                                 &aux (fd (socket-file-descriptor socket)))
  70         (sb-alien:with-alien ((buffer ,buffer-type))
  71           (setf buffer ,(if mangle-arg
  72                             `(,mangle-arg new-val)
  73                             `new-val))
  74           (when (= -1 (sockint::setsockopt fd ,find-level ,number
  75                                            (,mangle-setf-buffer buffer)
  76                                            ,(if (eql buffer-type 'sb-alien:c-string)
  77                                                 `(length new-val)
  78                                                 `(sb-alien:alien-size ,buffer-type :bytes))))
  79             (socket-error "setsockopt")))))))
  80
  81 ;;; sockopts that have integer arguments
  82
  83 (defun foreign-int-to-integer (buffer size)
  84   (assert (= size (sb-alien:alien-size sb-alien:integer :bytes)))
  85   buffer)
  86
  87 (defmacro define-socket-option-int (name level number)
  88   `(define-socket-option ,name ,level ,number
  89      sb-alien:integer nil foreign-int-to-integer sb-alien:addr))
  90
  91 (define-socket-option-int
  92   sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
  93 (define-socket-option-int
  94   sockopt-send-low-water sockint::sol-socket sockint::so-sndlowat)
  95 (define-socket-option-int
  96   sockopt-type sockint::sol-socket sockint::so-type)
  97 (define-socket-option-int
  98   sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf)
  99 (define-socket-option-int
 100   sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf)
 101 #+linux(define-socket-option-int
 102   sockopt-priority sockint::sol-socket sockint::so-priority)
 103
 104 ;;; boolean options are integers really
 105
 106 (defun foreign-int-to-bool (x size)
 107   (if (zerop (foreign-int-to-integer x size))
 108       nil
 109       t))
 110
 111 (defun bool-to-foreign-int (val)
 112   (if val 1 0))
 113
 114 (defmacro define-socket-option-bool (name level number)
 115   `(define-socket-option ,name ,level ,number
 116      sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr))
 117
 118 (define-socket-option-bool
 119   sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr)
 120 (define-socket-option-bool
 121   sockopt-keep-alive sockint::sol-socket sockint::so-keepalive)
 122 (define-socket-option-bool
 123   sockopt-oob-inline sockint::sol-socket sockint::so-oobinline)
 124 #+linux(define-socket-option-bool
 125   sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat)
 126 #+linux(define-socket-option-bool
 127   sockopt-pass-credentials sockint::sol-socket sockint::so-passcred)
 128 (define-socket-option-bool
 129   sockopt-debug sockint::sol-socket sockint::so-debug)
 130 (define-socket-option-bool
 131   sockopt-dont-route sockint::sol-socket sockint::so-dontroute)
 132 (define-socket-option-bool
 133   sockopt-broadcast sockint::sol-socket sockint::so-broadcast)
 134
 135 (define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay)
 136
 137 (defun identity-1 (x &rest args)
 138   (declare (ignore args))
 139   x)
 140
 141 #+linux(define-socket-option sockopt-bind-to-device sockint::sol-socket
 142   sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity)
 143
 144 ;;; other kinds of socket option
 145
 146 ;;; so_peercred takes a ucre structure
 147 ;;; so_linger struct linger {
 148 ;                  int   l_onoff;    /* linger active */
 149 ;                  int   l_linger;   /* how many seconds to linger for */
 150 ;              };
 151
 152 #|
 153
 154 (sockopt-reuse-address 2)
 155
 156 (defun echo-server ()
 157   (let ((s (make-inet-socket :stream (get-protocol-by-name "tcp"))))
 158     (setf (sockopt-reuse-address s) t)
 159     (setf (sockopt-bind-to-device s) "lo")
 160     (socket-bind s (make-inet-address "127.0.0.1") 3459)
 161     (socket-listen s 5)
 162     (dotimes (i 10)
 163       (let* ((s1 (socket-accept s))
 164              (stream (socket-make-stream s1 :input t :output t :buffering :none)))
 165         (let ((line (read-line stream)))
 166           (format t "got one ~A ~%" line)
 167           (format stream "~A~%" line))
 168         (close stream)))))
 169
 170 NIL
 171 |#
 172