src/sockets/common.lisp

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