contrib/sb-bsd-sockets/sockopt.lisp

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