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