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 (defmacro define-socket-option
  39     (lisp-name documentation
  40      level number buffer-type mangle-arg mangle-return mangle-setf-buffer
  41      &optional features info)
  42   (let ((find-level
  43          (if (numberp (eval level))
  44              level
  45              `(get-protocol-by-name ,(string-downcase (symbol-name level)))))
  46         (supportedp (or (null features) (sb-int:featurep features))))
  47     `(progn
  48       (export ',lisp-name)
  49       (defun ,lisp-name (socket)
  50         ,@(when documentation (list (concatenate 'string documentation " " info)))
  51         ,(if supportedp
  52              `(sb-alien:with-alien ((size sb-alien:int)
  53                                       (buffer ,buffer-type))
  54                   (setf size (sb-alien:alien-size ,buffer-type :bytes))
  55                   (if (= -1 (sockint::getsockopt (socket-file-descriptor socket)
  56                                                  ,find-level ,number
  57                                                  (sb-alien:addr buffer)
  58                                                  #+win32 size
  59                                                  #-win32 (sb-alien:addr size)))
  60                       (socket-error "getsockopt")
  61                       (,mangle-return buffer size)))
  62              `(error 'unsupported-operator
  63                :format-control "Socket option ~S is not supported in this platform."
  64                :format-arguments (list ',lisp-name))))
  65       (defun (setf ,lisp-name) (new-val socket)
  66         ,(if supportedp
  67              `(sb-alien:with-alien ((buffer ,buffer-type))
  68                   (setf buffer ,(if mangle-arg
  69                                     `(,mangle-arg new-val)
  70                                     `new-val))
  71                   (when (= -1 (sockint::setsockopt (socket-file-descriptor socket)
  72                                                    ,find-level ,number
  73                                                    (,mangle-setf-buffer buffer)
  74                                                    ,(if (eql buffer-type 'sb-alien:c-string)
  75                                                         `(length new-val)
  76                                                         `(sb-alien:alien-size ,buffer-type :bytes))))
  77                     (socket-error "setsockopt")))
  78              `(error 'unsupported-operator
  79                :format-control "Socket option ~S is not supported on this platform."
  80                :format-arguments (list ',lisp-name)))))))
  81
  82 ;;; sockopts that have integer arguments
  83
  84 (defun foreign-int-to-integer (buffer size)
  85   (assert (= size (sb-alien:alien-size sb-alien:int :bytes)))
  86   buffer)
  87
  88 (defmacro define-socket-option-int (name level number &optional features (info ""))
  89   `(define-socket-option ,name nil ,level ,number
  90      sb-alien:int nil foreign-int-to-integer sb-alien:addr ,features ,info))
  91
  92 (define-socket-option-int
  93   sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
  94 (define-socket-option-int
  95   sockopt-send-low-water sockint::sol-socket sockint::so-sndlowat)
  96 (define-socket-option-int
  97   sockopt-type sockint::sol-socket sockint::so-type)
  98 (define-socket-option-int
  99   sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf)
 100 (define-socket-option-int
 101   sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf)
 102 (define-socket-option-int
 103   sockopt-priority sockint::sol-socket sockint::so-priority :linux
 104   "Available only on Linux.")
 105
 106 (define-socket-option-int
 107   sockopt-tcp-keepcnt :tcp sockint::tcp-keepcnt :linux "Available only on Linux.")
 108 (define-socket-option-int
 109   sockopt-tcp-keepidle :tcp sockint::tcp-keepidle :linux "Available only on Linux.")
 110 (define-socket-option-int
 111   sockopt-tcp-keepintvl :tcp sockint::tcp-keepintvl :linux "Available only on Linux.")
 112
 113 ;;; boolean options are integers really
 114
 115 (defun foreign-int-to-bool (x size)
 116   (if (zerop (foreign-int-to-integer x size))
 117       nil
 118       t))
 119
 120 (defun bool-to-foreign-int (val)
 121   (if val 1 0))
 122
 123 (defmacro define-socket-option-bool (name level c-name &optional features (info ""))
 124   `(define-socket-option ,name
 125     ,(format nil "~@<Return the value of the ~A socket option for SOCKET. ~
 126                  This can also be updated with SETF.~:@>"
 127              (symbol-name c-name))
 128     ,level ,c-name
 129     sb-alien:int bool-to-foreign-int foreign-int-to-bool sb-alien:addr
 130     ,features ,info))
 131
 132 (define-socket-option-bool
 133   sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr)
 134 (define-socket-option-bool
 135   sockopt-keep-alive sockint::sol-socket sockint::so-keepalive)
 136 (define-socket-option-bool
 137   sockopt-oob-inline sockint::sol-socket sockint::so-oobinline)
 138 (define-socket-option-bool
 139   sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat :linux
 140   "Available only on Linux.")
 141 (define-socket-option-bool
 142   sockopt-pass-credentials sockint::sol-socket sockint::so-passcred :linux
 143   "Available only on Linux.")
 144 (define-socket-option-bool
 145   sockopt-debug sockint::sol-socket sockint::so-debug)
 146 (define-socket-option-bool
 147   sockopt-dont-route sockint::sol-socket sockint::so-dontroute)
 148 (define-socket-option-bool
 149   sockopt-broadcast sockint::sol-socket sockint::so-broadcast)
 150
 151 (define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay)
 152
 153 (defun identity-1 (x &rest args)
 154   (declare (ignore args))
 155   x)
 156
 157 (define-socket-option sockopt-bind-to-device nil sockint::sol-socket
 158   sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity
 159   :linux "Available only on Linux")
 160
 161 ;;; other kinds of socket option
 162
 163 ;;; so_peercred takes a ucre structure
 164 ;;; so_linger struct linger {
 165 ;                  int   l_onoff;    /* linger active */
 166 ;                  int   l_linger;   /* how many seconds to linger for */
 167 ;              };
 168
 169 #|
 170
 171 (sockopt-reuse-address 2)
 172
 173 (defun echo-server ()
 174   (let ((s (make-inet-socket :stream (get-protocol-by-name "tcp"))))
 175     (setf (sockopt-reuse-address s) t)
 176     (setf (sockopt-bind-to-device s) "lo")
 177     (socket-bind s (make-inet-address "127.0.0.1") 3459)
 178     (socket-listen s 5)
 179     (dotimes (i 10)
 180       (let* ((s1 (socket-accept s))
 181              (stream (socket-make-stream s1 :input t :output t :buffering :none)))
 182         (let ((line (read-line stream)))
 183           (format t "got one ~A ~%" line)
 184           (format stream "~A~%" line))
 185         (close stream)))))
 186
 187 NIL
 188 |#
 189