net.sockets/common.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; common.lisp --- Various helpers for bsd-sockets.
   4 ;;;
   5 ;;; Copyright (C) 2006-2008, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 ;;;; Types
  27
  28 (deftype ipv4-array () '(ub8-sarray 4))
  29 (deftype ipv6-array () '(ub16-sarray 8))
  30
  31 ;;;; Byte-swap functions
  32
  33 (defun htons (short)
  34   #+little-endian
  35   (logior (ash (logand (the ub16 short) #x00FF) 8)
  36           (ash (logand (the ub16 short) #xFF00) -8))
  37   #+big-endian short)
  38
  39 (defun ntohs (short)
  40   (htons short))
  41
  42 (defun htonl (long)
  43   #+little-endian
  44   (logior (ash (logand (the ub32 long) #x000000FF) 24)
  45           (ash (logand (the ub32 long) #x0000FF00) 8)
  46           (ash (logand (the ub32 long) #x00FF0000) -8)
  47           (ash (logand (the ub32 long) #xFF000000) -24))
  48   #+big-endian long)
  49
  50 (defun ntohl (long)
  51   (htonl long))
  52
  53 ;;;; Conversion between address formats
  54
  55 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec)
  56   (declare (type ipv6-array lisp-vec))
  57   (dotimes (i 8)
  58     (setf (mem-aref alien-vec :uint16 i)
  59           (htons (aref lisp-vec i)))))
  60
  61 (defun map-ipv4-vector-to-ipv6 (addr)
  62   (declare (type ipv4-array addr))
  63   (let ((ipv6addr (make-array 8 :element-type 'ub16
  64                               :initial-element 0)))
  65     ;; setting the IPv4 marker
  66     (setf (aref ipv6addr 5) #xFFFF)
  67     ;; setting the first two bytes
  68     (setf (aref ipv6addr 6) (+ (ash (aref addr 0) 8)
  69                                (aref addr 1)))
  70     ;; setting the last two bytes
  71     (setf (aref ipv6addr 7) (+ (ash (aref addr 2) 8)
  72                                (aref addr 3)))
  73     (values ipv6addr)))
  74
  75 (defun map-ipv6-vector-to-ipv4 (addr)
  76   (declare (type ipv6-array addr))
  77   (let ((ipv4addr (make-array 4 :element-type 'ub8
  78                               :initial-element 0)))
  79     (setf (aref ipv4addr 0) (ldb (byte 8 8) (aref addr 6)))
  80     (setf (aref ipv4addr 1) (ldb (byte 8 0) (aref addr 6)))
  81     (setf (aref ipv4addr 2) (ldb (byte 8 8) (aref addr 7)))
  82     (setf (aref ipv4addr 3) (ldb (byte 8 0) (aref addr 7)))
  83     (values ipv4addr)))
  84
  85 ;;; From CLOCC's PORT library.
  86 (defun vector-to-integer (vector)
  87   "Convert a vector to a 32-bit unsigned integer."
  88   (coercef vector 'ipv4-array)
  89   (+ (ash (aref vector 0) 24)
  90      (ash (aref vector 1) 16)
  91      (ash (aref vector 2) 8)
  92      (aref vector 3)))
  93
  94 (defun integer-to-vector (ipaddr)
  95   "Convert a 32-bit unsigned integer to a vector."
  96   (check-type ipaddr ub32 "an '(unsigned-byte 32)")
  97   (let ((vector (make-array 4 :element-type 'ub8)))
  98     (setf (aref vector 0) (ldb (byte 8 24) ipaddr)
  99           (aref vector 1) (ldb (byte 8 16) ipaddr)
 100           (aref vector 2) (ldb (byte 8  8) ipaddr)
 101           (aref vector 3) (ldb (byte 8  0) ipaddr))
 102     vector))
 103
 104 (defun in6-addr-to-ipv6-array (in6-addr)
 105   (let ((vector (make-array 8 :element-type 'ub16)))
 106     (dotimes (i 8)
 107       (setf (aref vector i)
 108             (ntohs (mem-aref in6-addr :uint16 i))))
 109     vector))
 110
 111 ;;;; Constructors for SOCKADDR_* structs
 112
 113 (defun make-sockaddr-in (sin ub8-vector &optional (portno 0))
 114   (declare (type ipv4-array ub8-vector) (type ub16 portno))
 115   (bzero sin size-of-sockaddr-in)
 116   (with-foreign-slots ((family addr port) sin sockaddr-in)
 117     (setf family af-inet)
 118     (setf addr (htonl (vector-to-integer ub8-vector)))
 119     (setf port (htons portno)))
 120   (values sin))
 121
 122 (defmacro with-sockaddr-in ((var address &optional (port 0)) &body body)
 123   `(with-foreign-object (,var 'sockaddr-in)
 124      (make-sockaddr-in ,var ,address ,port)
 125      ,@body))
 126
 127 (defun make-sockaddr-in6 (sin6 ub16-vector &optional (portno 0))
 128   (declare (type ipv6-array ub16-vector) (type ub16 portno))
 129   (bzero sin6 size-of-sockaddr-in6)
 130   (with-foreign-slots ((family addr port) sin6 sockaddr-in6)
 131     (setf family af-inet6)
 132     (copy-simple-array-ub16-to-alien-vector ub16-vector addr)
 133     (setf port (htons portno)))
 134   (values sin6))
 135
 136 (defmacro with-sockaddr-in6 ((var address &optional port) &body body)
 137   `(with-foreign-object (,var 'sockaddr-in6)
 138      (make-sockaddr-in6 ,var ,address ,port)
 139      ,@body))
 140
 141 (defun make-sockaddr-un (sun string)
 142   (declare (type string string))
 143   (bzero sun size-of-sockaddr-un)
 144   (with-foreign-slots ((family path) sun sockaddr-un)
 145     (setf family af-local)
 146     (with-foreign-string (c-string string)
 147       (loop :for off :below (1- unix-path-max)
 148             :do (setf (mem-aref path :uint8 off)
 149                       (mem-aref c-string :uint8 off)))))
 150   (values sun))
 151
 152 (defmacro with-sockaddr-un ((var address) &body body)
 153   `(with-foreign-object (,var 'sockaddr-un)
 154      (make-sockaddr-un ,var ,address)
 155      ,@body))
 156
 157 (defmacro with-sockaddr-storage ((var) &body body)
 158   `(with-foreign-object (,var 'sockaddr-storage)
 159      (bzero ,var size-of-sockaddr-storage)
 160      ,@body))
 161
 162 (defmacro with-socklen ((var value) &body body)
 163   `(with-foreign-object (,var 'socklen)
 164      (setf (mem-ref ,var 'socklen) ,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 (defmacro check-bounds (sequence start end)
 175   (with-gensyms (length)
 176     `(let ((,length (length ,sequence)))
 177        (check-type ,start unsigned-byte "a non-negative integer")
 178        (check-type ,end (or unsigned-byte null) "a non-negative integer or NIL")
 179        (unless ,end
 180          (setq ,end ,length))
 181        (unless (<= ,start ,end ,length)
 182          (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end)))))
 183
 184 (defun %to-octets (buff ef start end)
 185   (babel:string-to-octets buff :start start :end end
 186                           :encoding (babel:external-format-encoding ef)))
 187
 188 (declaim (inline ensure-number))
 189 (defun ensure-number (value &key (start 0) end (radix 10) (type t) (errorp t))
 190   (check-type value (or string unsigned-byte) "a string or an unsigned-byte")
 191   (let ((parsed
 192          (etypecase value
 193            (string
 194             (ignore-errors (parse-integer value :start start :end end
 195                                           :radix radix :junk-allowed nil)))
 196            (t value))))
 197     (if (and parsed (typep parsed type))
 198         (values parsed)
 199         (if errorp
 200             (error 'parse-error)
 201             nil))))
 202
 203 (defun ensure-string-or-unsigned-byte (thing &key (type t) (radix 10))
 204   (or (and (symbolp thing) (string-downcase thing))
 205       (ensure-number thing :type type :radix radix :errorp nil)
 206       thing))
 207
 208 (defun lisp->c-bool (val)
 209   (if val 1 0))
 210
 211 (defun memq (value list)
 212   (member value list :test #'eq))
 213
 214 (defmacro multiple-value-case ((values &key (test 'eql)) &body body)
 215   (setf values (ensure-list values))
 216   (setf test (alexandria::extract-function-name test))
 217   (assert values () "Must provide at least one value to test")
 218   (labels ((%do-var (var val)
 219              (cond
 220                ((and (symbolp var) (member var '("_" "*") :test #'string=))
 221                 t)
 222                ((consp var)
 223                 (if (eq 'eq test)
 224                     `(memq ,val ',var)
 225                     `(member ,val ',var :test ,test)))
 226                (t
 227                 `(,test ,val ',var))))
 228            (%do-clause (c gensyms)
 229              (destructuring-bind (vals &rest code) c
 230                (let* ((tests (remove t (mapcar #'%do-var (ensure-list vals) gensyms)))
 231                       (clause-test (if (> 2 (length tests))
 232                                        (first tests)
 233                                        `(and ,@tests))))
 234                  `(,clause-test ,@code))))
 235            (%do-last-clause (c gensyms)
 236              (when c
 237                (destructuring-bind (test &rest code) c
 238                  (if (member test '(otherwise t))
 239                      `((t ,@code))
 240                      `(,(%do-clause c gensyms)))))))
 241     (let ((gensyms (mapcar #'(lambda (v) (gensym (string v)))
 242                            values)))
 243       `(let ,(mapcar #'list gensyms values)
 244          (declare (ignorable ,@gensyms))
 245          (cond ,@(append (mapcar #'(lambda (c) (%do-clause c gensyms))
 246                                  (butlast body))
 247                          (%do-last-clause (lastcar body) gensyms)))))))
 248
 249 (eval-when (:compile-toplevel :load-toplevel :execute)
 250   (defun compute-flags (flags args)
 251     (loop :with flag-combination := 0
 252           :for cons :on args :by #'cddr
 253           :for flag := (car cons)
 254           :for val := (cadr cons)
 255           :for const := (cdr (assoc flag flags))
 256           :when const :do
 257        (when (not (constantp val)) (return-from compute-flags))
 258        (setf flag-combination (logior flag-combination const))
 259        :finally (return flag-combination))))
 260 \f
 261 ;;; Reader macros
 262
 263 (defgeneric enable-reader-macro* (name))
 264
 265 (defgeneric disable-reader-macro* (name))
 266
 267 (defmacro enable-reader-macro (name)
 268   `(eval-when (:compile-toplevel :load-toplevel :execute)
 269      (enable-reader-macro* ,name)))
 270
 271 (defmacro disable-reader-macro (name)
 272   `(eval-when (:compile-toplevel :load-toplevel :execute)
 273      (disable-reader-macro* ,name)))
 274
 275 (defun save-old-readtable (symbol readtable)
 276   (setf (getf (symbol-plist symbol) 'old-readtable) readtable))
 277
 278 (defun get-old-readtable (symbol readtable)
 279   (getf (symbol-plist symbol) 'old-readtable))
 280
 281 (defmethod enable-reader-macro* :before ((name symbol))
 282   (save-old-readtable name *readtable*)
 283   (setf *readtable* (copy-readtable)))
 284
 285 (defmethod disable-reader-macro* ((name symbol))
 286   (assert (readtablep (get-old-readtable name 'old-readtable)))
 287   (setf *readtable* (get-old-readtable name 'old-readtable))
 288   (save-old-readtable name nil))
 289
 290 (defmacro define-syntax (name &body body)
 291   `(defmethod enable-reader-macro* ((name (eql ',name)))
 292      ,@body))
 293
 294 ;;; Literal hash tables reader macro
 295
 296 (defun make-ht-from-list (alist stream test)
 297   (flet ((err () (error 'reader-error :stream stream))
 298          (alistp (alist) (every #'consp alist)))
 299     (unless (alistp alist) (err))
 300     (alist-hash-table alist :test test :size (length alist))))
 301
 302 (defun read-literal-ht (stream &optional c n)
 303   (declare (ignore c n))
 304   (let ((*readtable* (copy-readtable))
 305         (c (read-char stream))
 306         (test 'eql))
 307     (flet ((err () (error 'reader-error :stream stream)))
 308       (case c
 309         (#\( t)
 310         (#\: (let ((l (read-delimited-list #\( stream)))
 311                (unless (= 1 (length l)) (err))
 312                (setf test (car l))))
 313         (t   (err))))
 314     (make-ht-from-list (read-delimited-list #\) stream)
 315                        stream test)))
 316
 317 (define-syntax literal-hash-table
 318   (set-dispatch-macro-character #\# #\h 'read-literal-ht))