src/sockets/common.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Various helpers for bsd-sockets.
   4 ;;;
   5
   6 (in-package :iolib/sockets)
   7
   8 ;;;; Types
   9
  10 (deftype ipv4-array () '(ub8-sarray 4))
  11 (deftype ipv6-array () '(ub16-sarray 8))
  12
  13 ;;;; Conversion between address formats
  14
  15 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec)
  16   (declare (type ipv6-array lisp-vec))
  17   (dotimes (i 8)
  18     (setf (mem-aref alien-vec :uint16 i)
  19           (htons (aref lisp-vec i)))))
  20
  21 (defun map-ipv4-vector-to-ipv6 (addr)
  22   (declare (type ipv4-array addr))
  23   (let ((ipv6addr (make-array 8 :element-type 'ub16
  24                               :initial-element 0)))
  25     ;; setting the IPv4 marker
  26     (setf (aref ipv6addr 5) #xFFFF)
  27     ;; setting the first two bytes
  28     (setf (aref ipv6addr 6) (+ (ash (aref addr 0) 8)
  29                                (aref addr 1)))
  30     ;; setting the last two bytes
  31     (setf (aref ipv6addr 7) (+ (ash (aref addr 2) 8)
  32                                (aref addr 3)))
  33     (values ipv6addr)))
  34
  35 (defun map-ipv6-vector-to-ipv4 (addr)
  36   (declare (type ipv6-array addr))
  37   (let ((ipv4addr (make-array 4 :element-type 'ub8
  38                               :initial-element 0)))
  39     (setf (aref ipv4addr 0) (ldb (byte 8 8) (aref addr 6)))
  40     (setf (aref ipv4addr 1) (ldb (byte 8 0) (aref addr 6)))
  41     (setf (aref ipv4addr 2) (ldb (byte 8 8) (aref addr 7)))
  42     (setf (aref ipv4addr 3) (ldb (byte 8 0) (aref addr 7)))
  43     (values ipv4addr)))
  44
  45 ;;; From CLOCC's PORT library.
  46 (defun vector-to-integer (vector)
  47   "Convert a vector to a 32-bit unsigned integer."
  48   (coercef vector 'ipv4-array)
  49   (+ (ash (aref vector 0) 24)
  50      (ash (aref vector 1) 16)
  51      (ash (aref vector 2) 8)
  52      (aref vector 3)))
  53
  54 (defun integer-to-vector (ipaddr)
  55   "Convert a 32-bit unsigned integer to a vector."
  56   (check-type ipaddr ub32 "an '(unsigned-byte 32)")
  57   (let ((vector (make-array 4 :element-type 'ub8)))
  58     (setf (aref vector 0) (ldb (byte 8 24) ipaddr)
  59           (aref vector 1) (ldb (byte 8 16) ipaddr)
  60           (aref vector 2) (ldb (byte 8  8) ipaddr)
  61           (aref vector 3) (ldb (byte 8  0) ipaddr))
  62     vector))
  63
  64 (defun in6-addr-to-ipv6-array (in6-addr)
  65   (let ((vector (make-array 8 :element-type 'ub16)))
  66     (dotimes (i 8)
  67       (setf (aref vector i)
  68             (ntohs (mem-aref in6-addr :uint16 i))))
  69     vector))
  70
  71 ;;;; Constructors for SOCKADDR_* structs
  72
  73 (defun make-sockaddr-in (sin ub8-vector &optional (portno 0))
  74   (declare (type ipv4-array ub8-vector) (type ub16 portno))
  75   (isys:bzero sin (isys:sizeof '(:struct sockaddr-in)))
  76   (with-foreign-slots ((family addr port) sin (:struct sockaddr-in))
  77     (setf family af-inet)
  78     (setf addr (htonl (vector-to-integer ub8-vector)))
  79     (setf port (htons portno)))
  80   (values sin))
  81
  82 (defmacro with-sockaddr-in ((var address &optional (port 0)) &body body)
  83   `(with-foreign-object (,var '(:struct sockaddr-in))
  84      (make-sockaddr-in ,var ,address ,port)
  85      ,@body))
  86
  87 (defun make-sockaddr-in6 (sin6 ub16-vector &optional (portno 0))
  88   (declare (type ipv6-array ub16-vector) (type ub16 portno))
  89   (isys:bzero sin6 (isys:sizeof '(:struct sockaddr-in6)))
  90   (with-foreign-slots ((family addr port) sin6 (:struct sockaddr-in6))
  91     (setf family af-inet6)
  92     (copy-simple-array-ub16-to-alien-vector ub16-vector addr)
  93     (setf port (htons portno)))
  94   (values sin6))
  95
  96 (defmacro with-sockaddr-in6 ((var address &optional port) &body body)
  97   `(with-foreign-object (,var '(:struct sockaddr-in6))
  98      (make-sockaddr-in6 ,var ,address ,port)
  99      ,@body))
 100
 101 (defun make-sockaddr-un (sun string abstract)
 102   (declare (type string string))
 103   (isys:bzero sun (isys:sizeof '(:struct sockaddr-un)))
 104   (with-foreign-slots ((family path) sun (:struct sockaddr-un))
 105     (setf family af-local)
 106     (let* ((address-string
 107             (concatenate 'string (when abstract (string #\Null)) string))
 108            (path-length (length address-string))
 109            (sun-path-len
 110             (load-time-value
 111              (- (isys:sizeof '(:struct sockaddr-un))
 112                 (foreign-slot-offset '(:struct sockaddr-un) 'path)))))
 113       (assert (< path-length sun-path-len))
 114       (with-foreign-string (c-string address-string :null-terminated-p nil)
 115         (isys:memcpy (foreign-slot-pointer sun '(:struct sockaddr-un) 'path)
 116                      c-string path-length))))
 117   (values sun))
 118
 119 (defun actual-size-of-sockaddr-un (sun)
 120   (let ((path-ptr (foreign-slot-pointer sun '(:struct sockaddr-un) 'path))
 121         (sun-path-len
 122          (load-time-value
 123           (- (isys:sizeof '(:struct sockaddr-un))
 124              (foreign-slot-offset '(:struct sockaddr-un) 'path)))))
 125     (loop :for i :from 1 :below sun-path-len
 126           :if (zerop (mem-aref path-ptr :char i))
 127           :do (return (+ i (foreign-slot-offset '(:struct sockaddr-un) 'path)))
 128           :finally (bug "Invalid sockaddr_un struct: slot sun_path contains invalid C string"))))
 129
 130 (defmacro with-sockaddr-un ((var address abstract) &body body)
 131   `(with-foreign-object (,var '(:struct sockaddr-un))
 132      (make-sockaddr-un ,var ,address ,abstract)
 133      ,@body))
 134
 135 #+linux
 136 (defun make-sockaddr-nl (snl multicast-groups &optional (portno 0))
 137   (declare (type ub32 multicast-groups)
 138            (type ub32 portno))
 139   (isys:bzero snl (isys:sizeof '(:struct sockaddr-nl)))
 140   (with-foreign-slots ((family groups port) snl (:struct sockaddr-nl))
 141     (setf family af-netlink)
 142     (setf groups multicast-groups)
 143     (setf port portno))
 144   (values snl))
 145
 146 #+linux
 147 (defmacro with-sockaddr-nl ((var multicast-groups &optional (port 0)) &body body)
 148   `(with-foreign-object (,var '(:struct sockaddr-nl))
 149      (make-sockaddr-nl ,var ,multicast-groups ,port)
 150      ,@body))
 151
 152 (defmacro with-sockaddr-storage ((var) &body body)
 153   `(with-foreign-object (,var '(:struct sockaddr-storage))
 154      (isys:bzero ,var (isys:sizeof '(:struct sockaddr-storage)))
 155      ,@body))
 156
 157 (defmacro with-socklen ((var value) &body body)
 158   `(with-foreign-object (,var 'socklen-t)
 159      (setf (mem-aref ,var 'socklen-t) ,value)
 160      ,@body))
 161
 162 (defmacro with-sockaddr-storage-and-socklen ((ss-var size-var) &body body)
 163   `(with-sockaddr-storage (,ss-var)
 164      (with-socklen (,size-var (isys:sizeof '(:struct sockaddr-storage)))
 165        ,@body)))
 166
 167 ;;;; Misc
 168
 169 (defun ensure-number (value &key (start 0) end (radix 10) (type t) (errorp t))
 170   (let ((parsed
 171          (typecase value
 172            (string
 173             (ignore-errors (parse-integer value :start start :end end
 174                                           :radix radix :junk-allowed nil)))
 175            (t value))))
 176     (cond
 177       ((typep parsed type) parsed)
 178       (errorp (error 'parse-error)))))
 179
 180 (defun ensure-string-or-unsigned-byte (thing &key (type t) (radix 10) (errorp t))
 181   (or (and (symbolp thing) (string-downcase thing))
 182       (ensure-number thing :type type :radix radix :errorp nil)
 183       (and (stringp thing) thing)
 184       (if errorp (error 'parse-error) nil)))
 185
 186 (defun lisp->c-bool (val)
 187   (if val 1 0))
 188
 189 ;; FIXME: perhaps return some very large value instead of NIL
 190 (defun wait->timeout (wait)
 191   (case wait
 192     ((nil) 0)
 193     ((t)   nil)
 194     (t     wait)))
 195
 196 (defun compute-flags (flags args &optional env)
 197   (loop :with flag-combination := 0
 198         :for cons :on args :by #'cddr
 199         :for flag := (car cons)
 200         :for val := (cadr cons)
 201         :for const := (cdr (assoc flag flags))
 202         :when const
 203         :do (when (not (constantp val env)) (return* nil))
 204             (setf flag-combination (logior flag-combination const))
 205         :finally (return flag-combination)))
 206
 207 (defun set-function-docstring (function docstring)
 208   (setf (documentation function 'function) docstring))
 209
 210 (defun unset-method-docstring (gf qualifiers specializers)
 211   (setf (documentation (find-method gf qualifiers (mapcar #'find-class specializers)) t) nil))