sockets/common.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 ;;;
  25 ;;; Types
  26 ;;;
  27
  28 (deftype ub8  () `(unsigned-byte 8))
  29 (deftype ub16 () `(unsigned-byte 16))
  30 (deftype ub32 () `(unsigned-byte 32))
  31 (deftype sb8  () `(signed-byte 8))
  32 (deftype sb16 () `(signed-byte 16))
  33 (deftype sb32 () `(signed-byte 32))
  34
  35 (deftype ub8-sarray (&optional (size '*))
  36   `(simple-array ub8 (,size)))
  37 (deftype ub8-vector ()
  38   '(vector ub8))
  39 (deftype ub16-sarray (&optional (size '*))
  40   `(simple-array ub16 (,size)))
  41 (deftype ipv4-array ()
  42   '(ub8-sarray 4))
  43 (deftype ipv6-array ()
  44   '(ub16-sarray 8))
  45
  46 (define-modify-macro coercef (type-spec) coerce)
  47 \f
  48 ;;;
  49 ;;; Byte-swap functions
  50 ;;;
  51
  52 (defun htons (short)
  53   (check-type short ub16 "a 16-bit unsigned number")
  54   #+little-endian
  55   (logior (ash (logand (the ub16 short) #x00FF) 8)
  56           (ash (logand (the ub16 short) #xFF00) -8))
  57   #+big-endian short)
  58
  59 (defun ntohs (short)
  60   (htons short))
  61
  62 (defun htonl (long)
  63   (check-type long ub32 "a 32-bit unsigned number")
  64   #+little-endian
  65   (logior (ash (logand (the ub32 long) #x000000FF) 24)
  66           (ash (logand (the ub32 long) #x0000FF00) 8)
  67           (ash (logand (the ub32 long) #x00FF0000) -8)
  68           (ash (logand (the ub32 long) #xFF000000) -24))
  69   #+big-endian long)
  70
  71 (defun ntohl (long)
  72   (htonl long))
  73 \f
  74 ;;;
  75 ;;; Conversion between address formats
  76 ;;;
  77
  78 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec)
  79   (declare (type ipv6-array lisp-vec))
  80   (dotimes (i 8)
  81     (setf (mem-aref alien-vec :uint16 i)
  82           (htons (aref lisp-vec i)))))
  83
  84 (defun map-ipv4-vector-to-ipv6 (addr)
  85   (declare (type ipv4-array addr))
  86   (let ((ipv6addr (make-array 8 :element-type 'ub16
  87                                 :initial-element 0)))
  88     ;; setting the IPv4 marker
  89     (setf (aref ipv6addr 5) #xFFFF)
  90     ;; setting the first two bytes
  91     (setf (aref ipv6addr 6) (+ (ash (aref addr 0) 8)
  92                                (aref addr 1)))
  93     ;; setting the last two bytes
  94     (setf (aref ipv6addr 7) (+ (ash (aref addr 2) 8)
  95                                (aref addr 3)))
  96
  97     ipv6addr))
  98
  99 ;; From CLOCC's PORT library
 100 (defun vector-to-ipaddr (vector)
 101   (coercef vector 'ipv4-array)
 102   (+ (ash (aref vector 0) 24)
 103      (ash (aref vector 1) 16)
 104      (ash (aref vector 2) 8)
 105      (aref vector 3)))
 106
 107 (defun ipaddr-to-vector (ipaddr)
 108   (check-type ipaddr ub32)
 109   (let ((vector (make-array 4 :element-type 'ub8)))
 110     (setf (aref vector 0) (ldb (byte 8 24) ipaddr)
 111           (aref vector 1) (ldb (byte 8 16) ipaddr)
 112           (aref vector 2) (ldb (byte 8  8) ipaddr)
 113           (aref vector 3) (ldb (byte 8  0) ipaddr))
 114     vector))
 115
 116 (defun in6-addr-to-ipv6-array (in6-addr)
 117   (let ((vector (make-array 8 :element-type 'ub16)))
 118     (dotimes (i 8)
 119       (setf (aref vector i)
 120             (ntohs (mem-aref in6-addr :uint16 i))))
 121     vector))
 122 \f
 123 ;;;
 124 ;;; Constructors for SOCKADDR_* structs
 125 ;;;
 126
 127 (defun make-sockaddr-in (sin ub8-vector &optional (port 0))
 128   (et:bzero sin et:size-of-sockaddr-in)
 129   (let ((tmp port))
 130     (with-foreign-slots ((et:family et:addr et:port) sin et:sockaddr-in)
 131       (setf et:family et:af-inet)
 132       (setf et:addr (htonl (vector-to-ipaddr ub8-vector)))
 133       (setf et:port (htons tmp))))
 134   sin)
 135
 136 (defun make-sockaddr-in6 (sin6 ub16-vector &optional (port 0))
 137   (et:bzero sin6 et:size-of-sockaddr-in6)
 138   (let ((tmp port))
 139     (with-foreign-slots ((et:family et:addr et:port) sin6 et:sockaddr-in6)
 140       (setf et:family et:af-inet6)
 141       (copy-simple-array-ub16-to-alien-vector ub16-vector et:addr)
 142       (setf et:port (htons tmp))))
 143   sin6)
 144
 145 (defun make-sockaddr-un (sun string)
 146   (check-type string string)
 147   (et:bzero sun et:size-of-sockaddr-un)
 148   (with-foreign-slots ((et:family et:path) sun et:sockaddr-un)
 149     (setf et:family et:af-local)
 150     (with-foreign-string (c-string string)
 151       (loop
 152          :for off :below (1- et:unix-path-max)
 153          :do (setf (mem-aref et:path :uint8 off)
 154                    (mem-aref c-string :uint8 off)))))
 155   sun)
 156 \f
 157 ;;;
 158 ;;; Conversion functions for SOCKADDR_* structs
 159 ;;;
 160
 161 (defun sockaddr-in->sockaddr (sin)
 162   (with-foreign-slots ((et:addr et:port) sin et:sockaddr-in)
 163     (values (make-instance 'ipv4addr
 164                            :name (ipaddr-to-vector (ntohl et:addr)))
 165             (ntohs et:port))))
 166
 167 (defun sockaddr-in6->sockaddr (sin6)
 168   (with-foreign-slots ((et:addr et:port) sin6 et:sockaddr-in6)
 169     (values (make-instance 'ipv6addr
 170                            :name (in6-addr-to-ipv6-array et:addr))
 171             (ntohs et:port))))
 172
 173 (defun sockaddr-un->sockaddr (sun)
 174   (with-foreign-slots ((et:path) sun et:sockaddr-un)
 175     (let ((name (make-string (1- et:unix-path-max)))
 176           (abstract nil))
 177       (if (zerop (mem-aref et:path :uint8 0))
 178           ;; abstract address
 179           (progn
 180             (setf abstract t)
 181             (loop
 182                :for sindex :from 0 :below (1- et:unix-path-max)
 183                :for pindex :from 1 :below et:unix-path-max
 184                :do (setf (schar name sindex)
 185                          (code-char (mem-aref et:path :uint8 pindex)))))
 186           ;; address is in the filesystem
 187           (setf name (foreign-string-to-lisp et:path)))
 188       (make-instance 'localaddr
 189                      :name name
 190                      :abstract abstract))))
 191
 192 (defun sockaddr-storage->sockaddr (ss)
 193   (with-foreign-slots ((et:family) ss et:sockaddr-storage)
 194     (ecase et:family
 195       (#.et:af-inet
 196        (sockaddr-in->sockaddr ss))
 197       (#.et:af-inet6
 198        (sockaddr-in6->sockaddr ss))
 199       (#.et:af-local
 200        (sockaddr-un->sockaddr ss)))))
 201
 202 (defun sockaddr->sockaddr-storage (ss sockaddr &optional (port 0))
 203   (etypecase sockaddr
 204     (ipv4addr
 205      (make-sockaddr-in ss (name sockaddr) port))
 206     (ipv6addr
 207      (make-sockaddr-in6 ss (name sockaddr) port))
 208     (localaddr
 209      (make-sockaddr-un ss (name sockaddr)))))
 210 \f
 211 ;;;
 212 ;;; Misc
 213 ;;;
 214
 215 (defun %check-bounds (sequence start end)
 216   (unless end (setf end (length sequence)))
 217   (when (> start end) (error "~S ~S wrong sequence bounds" start end))
 218   (values start end))
 219
 220 (defun %to-octets (buff ef start end)
 221   (io.encodings:string-to-octets buff :external-format ef
 222                                  :start start :end end))
 223
 224 (defun parse-number-or-nil (value &optional (type :any) (radix 10))
 225   (check-type value (or string unsigned-byte))
 226   (let ((parsed
 227          (if (stringp value)
 228              (ignore-errors (parse-integer value :radix radix
 229                                            :junk-allowed nil))
 230              value)))
 231     (if parsed
 232         ;; if it's a number and its type is ok return it
 233         (and (ecase type
 234                (:any  t)
 235                (:ub8  (typep parsed 'ub8))
 236                (:ub16 (typep parsed 'ub16))
 237                (:ub32 (typep parsed 'ub32)))
 238              parsed)
 239         ;; otherwise nil
 240         nil)))
 241
 242 (defun c->lisp-bool (val)
 243   (if (zerop val) nil t))
 244
 245 (defun lisp->c-bool (val)
 246   (if val 1 0))
 247
 248 (defun addrerr-value (keyword)
 249   (foreign-enum-value 'et:addrinfo-errors keyword))
 250
 251 (defun unixerr-value (keyword)
 252   (foreign-enum-value 'et:errno-values keyword))