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-2007, 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   (check-type short ub16 "a 16-bit unsigned number")
  35   #+little-endian
  36   (logior (ash (logand (the ub16 short) #x00FF) 8)
  37           (ash (logand (the ub16 short) #xFF00) -8))
  38   #+big-endian short)
  39
  40 (defun ntohs (short)
  41   (htons short))
  42
  43 (defun htonl (long)
  44   (check-type long ub32 "a 32-bit unsigned number")
  45   #+little-endian
  46   (logior (ash (logand (the ub32 long) #x000000FF) 24)
  47           (ash (logand (the ub32 long) #x0000FF00) 8)
  48           (ash (logand (the ub32 long) #x00FF0000) -8)
  49           (ash (logand (the ub32 long) #xFF000000) -24))
  50   #+big-endian long)
  51
  52 (defun ntohl (long)
  53   (htonl long))
  54
  55 ;;;; Conversion between address formats
  56
  57 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec)
  58   (declare (type ipv6-array lisp-vec))
  59   (dotimes (i 8)
  60     (setf (mem-aref alien-vec :uint16 i)
  61           (htons (aref lisp-vec i)))))
  62
  63 (defun map-ipv4-vector-to-ipv6 (addr)
  64   (declare (type ipv4-array addr))
  65   (let ((ipv6addr (make-array 8 :element-type 'ub16
  66                               :initial-element 0)))
  67     ;; setting the IPv4 marker
  68     (setf (aref ipv6addr 5) #xFFFF)
  69     ;; setting the first two bytes
  70     (setf (aref ipv6addr 6) (+ (ash (aref addr 0) 8)
  71                                (aref addr 1)))
  72     ;; setting the last two bytes
  73     (setf (aref ipv6addr 7) (+ (ash (aref addr 2) 8)
  74                                (aref addr 3)))
  75     (values ipv6addr)))
  76
  77 (defun map-ipv6-vector-to-ipv4 (addr)
  78   (declare (type ipv6-array addr))
  79   (let ((ipv4addr (make-array 4 :element-type 'ub8
  80                               :initial-element 0)))
  81     (setf (aref ipv4addr 0) (ldb (byte 8 8) (aref addr 6)))
  82     (setf (aref ipv4addr 1) (ldb (byte 8 0) (aref addr 6)))
  83     (setf (aref ipv4addr 2) (ldb (byte 8 8) (aref addr 7)))
  84     (setf (aref ipv4addr 3) (ldb (byte 8 0) (aref addr 7)))
  85     (values ipv4addr)))
  86
  87 ;;; From CLOCC's PORT library.
  88 (defun vector-to-integer (vector)
  89   "Convert a vector to a 32-bit unsigned integer."
  90   (coercef vector 'ipv4-array)
  91   (+ (ash (aref vector 0) 24)
  92      (ash (aref vector 1) 16)
  93      (ash (aref vector 2) 8)
  94      (aref vector 3)))
  95
  96 (defun integer-to-vector (ipaddr)
  97   "Convert a 32-bit unsigned integer to a vector."
  98   (check-type ipaddr ub32)
  99   (let ((vector (make-array 4 :element-type 'ub8)))
 100     (setf (aref vector 0) (ldb (byte 8 24) ipaddr)
 101           (aref vector 1) (ldb (byte 8 16) ipaddr)
 102           (aref vector 2) (ldb (byte 8  8) ipaddr)
 103           (aref vector 3) (ldb (byte 8  0) ipaddr))
 104     vector))
 105
 106 (defun in6-addr-to-ipv6-array (in6-addr)
 107   (let ((vector (make-array 8 :element-type 'ub16)))
 108     (dotimes (i 8)
 109       (setf (aref vector i)
 110             (ntohs (mem-aref in6-addr :uint16 i))))
 111     vector))
 112
 113 ;;;; Constructors for SOCKADDR_* structs
 114
 115 (defun make-sockaddr-in (sin ub8-vector &optional (portno 0))
 116   (declare (type ipv4-array ub8-vector) (type ub16 portno))
 117   (bzero sin size-of-sockaddr-in)
 118   (with-foreign-slots ((family addr port) sin sockaddr-in)
 119     (setf family af-inet)
 120     (setf addr (htonl (vector-to-integer ub8-vector)))
 121     (setf port (htons portno)))
 122   (values sin))
 123
 124 (defmacro with-sockaddr-in ((var address &optional (port 0)) &body body)
 125   `(with-foreign-object (,var 'sockaddr-in)
 126      (make-sockaddr-in ,var ,address ,port)
 127      ,@body))
 128
 129 (defun make-sockaddr-in6 (sin6 ub16-vector &optional (portno 0))
 130   (declare (type ipv6-array ub16-vector) (type ub16 portno))
 131   (bzero sin6 size-of-sockaddr-in6)
 132   (with-foreign-slots ((family addr port) sin6 sockaddr-in6)
 133     (setf family af-inet6)
 134     (copy-simple-array-ub16-to-alien-vector ub16-vector addr)
 135     (setf port (htons portno)))
 136   (values sin6))
 137
 138 (defmacro with-sockaddr-in6 ((var address &optional port) &body body)
 139   `(with-foreign-object (,var 'sockaddr-in6)
 140      (make-sockaddr-in6 ,var ,address ,port)
 141      ,@body))
 142
 143 (defun make-sockaddr-un (sun string)
 144   (declare (type string string))
 145   (bzero sun size-of-sockaddr-un)
 146   (with-foreign-slots ((family path) sun sockaddr-un)
 147     (setf family af-local)
 148     (with-foreign-string (c-string string)
 149       (loop :for off :below (1- unix-path-max)
 150             :do (setf (mem-aref path :uint8 off)
 151                       (mem-aref c-string :uint8 off)))))
 152   (values sun))
 153
 154 (defmacro with-sockaddr-un ((var address) &body body)
 155   `(with-foreign-object (,var 'sockaddr-un)
 156      (make-sockaddr-un ,var ,address)
 157      ,@body))
 158
 159 ;;;; Conversion functions for SOCKADDR_* structs
 160
 161 (defun sockaddr-in->sockaddr (sin)
 162   (with-foreign-slots ((addr port) sin sockaddr-in)
 163     (values (make-instance 'ipv4-address
 164                            :name (integer-to-vector (ntohl addr)))
 165             (ntohs port))))
 166
 167 (defun sockaddr-in6->sockaddr (sin6)
 168   (with-foreign-slots ((addr port) sin6 sockaddr-in6)
 169     (values (make-instance 'ipv6-address
 170                            :name (in6-addr-to-ipv6-array addr))
 171             (ntohs port))))
 172
 173 (defun sockaddr-un->sockaddr (sun)
 174   (with-foreign-slots ((path) sun sockaddr-un)
 175     (let ((name (make-string (1- unix-path-max)))
 176           (abstract nil))
 177       (cond ((zerop (mem-aref path :uint8 0))
 178              ;; abstract address
 179              (setf abstract t)
 180              (loop :for sindex :from 0 :below (1- unix-path-max)
 181                    :for pindex :from 1 :below unix-path-max
 182                    :do (setf (schar name sindex)
 183                              (code-char (mem-aref path :uint8 pindex)))))
 184             (t
 185              ;; address is in the filesystem
 186              (setf name (foreign-string-to-lisp path))))
 187       (make-instance 'local-address
 188                      :name name
 189                      :abstract abstract))))
 190
 191 (defun sockaddr-storage->sockaddr (ss)
 192   (with-foreign-slots ((family) ss sockaddr-storage)
 193     (ecase family
 194       (#.af-inet (sockaddr-in->sockaddr ss))
 195       (#.af-inet6 (sockaddr-in6->sockaddr ss))
 196       (#.af-local (sockaddr-un->sockaddr ss)))))
 197
 198 (defun sockaddr->sockaddr-storage (ss sockaddr &optional (port 0))
 199   (etypecase sockaddr
 200     (ipv4-address (make-sockaddr-in ss (address-name sockaddr) port))
 201     (ipv6-address (make-sockaddr-in6 ss (address-name sockaddr) port))
 202     (local-address (make-sockaddr-un ss (address-name sockaddr)))))
 203
 204 ;;;; Misc
 205
 206 (defmacro check-bounds (sequence start end)
 207   (with-gensyms (length)
 208     `(let ((,length (length ,sequence)))
 209        (unless ,end
 210          (setq ,end ,length))
 211        (unless (<= ,start ,end ,length)
 212          (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end)))))
 213
 214 (defun %to-octets (buff ef start end)
 215   (babel:string-to-octets buff :start start :end end
 216                           :encoding (babel:external-format-encoding ef)))
 217
 218 (defun parse-number-or-nil (value &optional (type :any) (radix 10))
 219   (check-type value (or string unsigned-byte))
 220   (let ((parsed
 221          (if (stringp value)
 222              (ignore-errors (parse-integer value :radix radix
 223                                            :junk-allowed nil))
 224              value)))
 225     (and parsed
 226          ;; if it's a number and its type is ok return it
 227          (typep parsed (ecase type
 228                          (:any  t)     (:ub8  'ub8)
 229                          (:ub16 'ub16) (:ub32 'ub32)))
 230          (values parsed))))
 231
 232 (defun lisp->c-bool (val)
 233   (if val 1 0))
 234
 235 (defmacro with-socklen ((var value) &body body)
 236   `(with-foreign-object (,var 'socklen)
 237      (setf (mem-ref ,var 'socklen) ,value)
 238      ,@body))