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 (defmacro check-bounds (sequence start end)
 157   (with-gensyms (length)
 158     `(let ((,length (length ,sequence)))
 159        (check-type ,start unsigned-byte "a non-negative integer")
 160        (check-type ,end (or unsigned-byte null) "a non-negative integer or NIL")
 161        (unless ,end
 162          (setq ,end ,length))
 163        (unless (<= ,start ,end ,length)
 164          (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end)))))
 165
 166 (defun %to-octets (buff ef start end)
 167   (babel:string-to-octets buff :start start :end end
 168                           :encoding (babel:external-format-encoding ef)))
 169
 170 (defun ensure-number (value &key (start 0) end (radix 10) (type t) (errorp t))
 171   (let ((parsed
 172          (typecase value
 173            (string
 174             (ignore-errors (parse-integer value :start start :end end
 175                                           :radix radix :junk-allowed nil)))
 176            (t value))))
 177     (cond
 178       ((typep parsed type) parsed)
 179       (errorp (error 'parse-error)))))
 180
 181 (defun ensure-string-or-unsigned-byte (thing &key (type t) (radix 10) (errorp t))
 182   (or (and (symbolp thing) (string-downcase thing))
 183       (ensure-number thing :type type :radix radix :errorp nil)
 184       (and (stringp thing) thing)
 185       (if errorp (error 'parse-error) nil)))
 186
 187 (defun lisp->c-bool (val)
 188   (if val 1 0))
 189
 190 (defmacro multiple-value-case ((values &key (test 'eql)) &body body)
 191   (setf values (ensure-list values))
 192   (when (symbolp test) (setf test `(quote ,test)))
 193   (assert values () "Must provide at least one value to test")
 194   (let ((test-name (alexandria::extract-function-name test)))
 195     (labels ((%do-var (var val)
 196                (cond
 197                  ((and (symbolp var) (member var '("_" "*") :test #'string=))
 198                   t)
 199                  ((consp var)
 200                   `(member ,val ',var :test ,test))
 201                  (t
 202                   `(,test-name ,val ',var))))
 203              (%do-clause (c gensyms)
 204                (destructuring-bind (vals &rest code) c
 205                  (let* ((tests (remove t (mapcar #'%do-var (ensure-list vals) gensyms)))
 206                         (clause-test (if (> 2 (length tests))
 207                                          (first tests)
 208                                          `(and ,@tests))))
 209                    `(,clause-test ,@code))))
 210              (%do-last-clause (c gensyms)
 211                (when c
 212                  (destructuring-bind (test &rest code) c
 213                    (if (member test '(otherwise t))
 214                        `((t ,@code))
 215                        `(,(%do-clause c gensyms)))))))
 216       (let ((gensyms (mapcar (lambda (v) (gensym (string v)))
 217                              values)))
 218         `(let ,(mapcar #'list gensyms values)
 219            (declare (ignorable ,@gensyms))
 220            (cond ,@(append (mapcar (lambda (c) (%do-clause c gensyms))
 221                                    (butlast body))
 222                            (%do-last-clause (lastcar body) gensyms))))))))
 223
 224 (eval-when (:compile-toplevel :load-toplevel :execute)
 225   (defun compute-flags (flags args)
 226     (loop :with flag-combination := 0
 227           :for cons :on args :by #'cddr
 228           :for flag := (car cons)
 229           :for val := (cadr cons)
 230           :for const := (cdr (assoc flag flags))
 231           :when const :do
 232        (when (not (constantp val)) (return* nil))
 233        (setf flag-combination (logior flag-combination const))
 234        :finally (return flag-combination))))
 235
 236 (defun set-function-docstring (function docstring)
 237   (setf (documentation function 'function) docstring))
 238
 239 (defun unset-method-docstring (gf qualifiers specializers)
 240   (setf (documentation (find-method gf qualifiers (mapcar #'find-class specializers)) t) nil))
 241 \f
 242 ;;; Reader macros
 243
 244 (defgeneric enable-reader-macro* (name))
 245
 246 (defgeneric disable-reader-macro* (name))
 247
 248 (defmacro enable-reader-macro (name)
 249   `(eval-when (:compile-toplevel)
 250      (enable-reader-macro* ,name)))
 251
 252 (defmacro disable-reader-macro (name)
 253   `(eval-when (:compile-toplevel)
 254      (disable-reader-macro* ,name)))
 255
 256 (defun save-old-readtable (symbol readtable)
 257   (setf (getf (symbol-plist symbol) 'old-readtable) readtable))
 258
 259 (defun get-old-readtable (symbol)
 260   (getf (symbol-plist symbol) 'old-readtable))
 261
 262 (defmethod enable-reader-macro* :before ((name symbol))
 263   (save-old-readtable name *readtable*)
 264   (setf *readtable* (copy-readtable)))
 265
 266 (defmethod disable-reader-macro* ((name symbol))
 267   (assert (readtablep (get-old-readtable name)))
 268   (setf *readtable* (get-old-readtable name))
 269   (save-old-readtable name nil))
 270
 271 (defmacro define-syntax (name &body body)
 272   `(defmethod enable-reader-macro* ((name (eql ',name)))
 273      ,@body))