sockets/common.lisp

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