net.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 :net.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   (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   (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)
 124   (declare (type string string))
 125   (bzero sun size-of-sockaddr-un)
 126   (with-foreign-slots ((family path) sun sockaddr-un)
 127     (setf family af-local)
 128     (with-foreign-string (c-string string)
 129       (loop :for off :below (1- unix-path-max)
 130             :do (setf (mem-aref path :uint8 off)
 131                       (mem-aref c-string :uint8 off)))))
 132   (values sun))
 133
 134 (defmacro with-sockaddr-un ((var address) &body body)
 135   `(with-foreign-object (,var 'sockaddr-un)
 136      (make-sockaddr-un ,var ,address)
 137      ,@body))
 138
 139 (defmacro with-sockaddr-storage ((var) &body body)
 140   `(with-foreign-object (,var 'sockaddr-storage)
 141      (bzero ,var size-of-sockaddr-storage)
 142      ,@body))
 143
 144 (defmacro with-socklen ((var value) &body body)
 145   `(with-foreign-object (,var 'socklen)
 146      (setf (mem-aref ,var 'socklen) ,value)
 147      ,@body))
 148
 149 (defmacro with-sockaddr-storage-and-socklen ((ss-var size-var) &body body)
 150   `(with-sockaddr-storage (,ss-var)
 151      (with-socklen (,size-var size-of-sockaddr-storage)
 152        ,@body)))
 153
 154 ;;;; Misc
 155
 156 (defun ensure-number (value &key (start 0) end (radix 10) (type t) (errorp t))
 157   (let ((parsed
 158          (typecase value
 159            (string
 160             (ignore-errors (parse-integer value :start start :end end
 161                                           :radix radix :junk-allowed nil)))
 162            (t value))))
 163     (cond
 164       ((typep parsed type) parsed)
 165       (errorp (error 'parse-error)))))
 166
 167 (defun ensure-string-or-unsigned-byte (thing &key (type t) (radix 10) (errorp t))
 168   (or (and (symbolp thing) (string-downcase thing))
 169       (ensure-number thing :type type :radix radix :errorp nil)
 170       (and (stringp thing) thing)
 171       (if errorp (error 'parse-error) nil)))
 172
 173 (defun lisp->c-bool (val)
 174   (if val 1 0))
 175
 176 (defun compute-flags (flags args)
 177   (loop :with flag-combination := 0
 178         :for cons :on args :by #'cddr
 179         :for flag := (car cons)
 180         :for val := (cadr cons)
 181         :for const := (cdr (assoc flag flags))
 182         :when const
 183         :do (when (not (constantp val)) (return* nil))
 184             (setf flag-combination (logior flag-combination const))
 185         :finally (return flag-combination)))
 186
 187 (defun set-function-docstring (function docstring)
 188   (setf (documentation function 'function) docstring))
 189
 190 (defun unset-method-docstring (gf qualifiers specializers)
 191   (setf (documentation (find-method gf qualifiers (mapcar #'find-class specializers)) t) nil))