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