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