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 string-or-parsed-number (val)
  39   (let ((tmpval val)
  40         type)
  41     (etypecase val
  42       (ub16
  43        (values :number val))
  44       (string
  45        (multiple-value-bind (parsed pos)
  46            (parse-integer val :junk-allowed t)
  47          (if (and parsed
  48                   (eql pos (length val))) ; the entire string is a number
  49              (progn
  50                (setf type :number)
  51                (setf tmpval parsed))
  52              (setf type :string))
  53          (values type tmpval))))))
  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 #+little-endian
  76   (let ((newshort 0))
  77     (declare (type ub16 newshort)
  78              (type ub16 short))
  79     (setf (ldb (byte 8 0) newshort) (ldb (byte 8 8) short))
  80     (setf (ldb (byte 8 8) newshort) (ldb (byte 8 0) short))
  81     newshort)
  82 #+big-endian short)
  83
  84 (defun ntohs (short)
  85   (htons short))
  86
  87 (defun htonl (long)
  88 #+little-endian
  89   (let ((newlong 0))
  90     (declare (type ub32 newlong)
  91              (type ub32 long))
  92     (setf (ldb (byte 8  0) newlong) (ldb (byte 8 24) long))
  93     (setf (ldb (byte 8 24) newlong) (ldb (byte 8  0) long))
  94     (setf (ldb (byte 8  8) newlong) (ldb (byte 8 16) long))
  95     (setf (ldb (byte 8 16) newlong) (ldb (byte 8  8) long))
  96     newlong)
  97 #+big-endian long)
  98
  99 (defun ntohl (long)
 100   (htonl long))
 101
 102 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec)
 103   (declare (type (simple-array ub16 (8)) lisp-vec))
 104   (dotimes (i 8)
 105     (setf (mem-aref alien-vec :uint16 i)
 106           (htons (aref lisp-vec i)))))
 107
 108 (defun map-ipv4-vector-to-ipv6 (addr)
 109   (declare (type (simple-array ub8 (*)) addr))
 110   (let ((ipv6addr (make-array 8 :element-type 'ub16
 111                                 :initial-element 0)))
 112     ;; setting the IPv4 marker
 113     (setf (aref ipv6addr 5) #xFFFF)
 114     ;; setting the first two bytes
 115     (setf (aref ipv6addr 6) (+ (ash (aref addr 0) 8)
 116                                (aref addr 1)))
 117     ;; setting the last two bytes
 118     (setf (aref ipv6addr 7) (+ (ash (aref addr 2) 8)
 119                                (aref addr 3)))
 120
 121     ipv6addr))
 122
 123 ;; From CLOCC's PORT library
 124 (defun vector-to-ipaddr (vector)
 125   (coerce vector '(simple-array ub8 (4)))
 126   (+ (ash (aref vector 0) 24)
 127      (ash (aref vector 1) 16)
 128      (ash (aref vector 2) 8)
 129      (aref vector 3)))
 130
 131 (defun make-sockaddr-in (sin ub8-vector &optional (port 0))
 132   (et:memset sin 0 #.(foreign-type-size 'et:sockaddr-in))
 133   (let ((tmp port))
 134     (with-foreign-slots ((et:family et:address et:port) sin et:sockaddr-in)
 135       (setf family et:af-inet)
 136       (setf address (htonl (vector-to-ipaddr ub8-vector)))
 137       (setf port (htons tmp))))
 138   sin)
 139
 140 (defun make-sockaddr-in6 (sin6 ub16-vector &optional (port 0))
 141   (et:memset sin6 0 #.(foreign-type-size 'et:sockaddr-in6))
 142   (let ((tmp port))
 143     (with-foreign-slots ((et:family et:address et:port) sin6 et:sockaddr-in6)
 144       (setf family et:af-inet6)
 145       (copy-simple-array-ub16-to-alien-vector ub16-vector address)
 146       (setf port (htons tmp))))
 147   sin6)
 148
 149 (defun make-sockaddr-un (sun string)
 150   (check-type string string)
 151   (et:memset sun 0 (foreign-type-size 'et:sockaddr-un))
 152   (with-foreign-slots ((et:family et:path) sun et:sockaddr-un)
 153     (setf family et:af-local)
 154     (with-foreign-string (c-string string)
 155       (loop
 156          :for off :below (1- et:unix-path-max)
 157          :do (setf (mem-aref path :uint8 off)
 158                    (mem-aref c-string :uint8 off)))))
 159   sun)
 160
 161 (defun make-vector-u8-4-from-in-addr (in-addr)
 162   (check-type in-addr ub32)
 163   (let ((vector (make-array 4 :element-type 'ub8)))
 164     (setf in-addr (ntohl in-addr))
 165     (setf (aref vector 0) (ldb (byte 8 24) in-addr))
 166     (setf (aref vector 1) (ldb (byte 8 16) in-addr))
 167     (setf (aref vector 2) (ldb (byte 8  8) in-addr))
 168     (setf (aref vector 3) (ldb (byte 8  0) in-addr))
 169     vector))
 170
 171 (defun make-vector-u16-8-from-in6-addr (in6-addr)
 172   (let ((newvector (make-array 8 :element-type 'ub16)))
 173     (dotimes (i 8)
 174       (setf (aref newvector i)
 175             (ntohs (mem-aref in6-addr :uint16 i))))
 176     newvector))
 177
 178 (defun sockaddr-in->netaddr (sin)
 179   (with-foreign-slots ((et:address et:port) sin et:sockaddr-in)
 180     (values (make-instance 'ipv4addr
 181                            :name (make-vector-u8-4-from-in-addr address))
 182             port)))
 183
 184 (defun sockaddr-in6->netaddr (sin6)
 185   (with-foreign-slots ((et:address et:port) sin6 et:sockaddr-in6)
 186     (values (make-instance 'ipv6addr
 187                            :name (make-vector-u16-8-from-in6-addr address))
 188             port)))
 189
 190 (defun sockaddr-un->netaddr (sun)
 191   (with-foreign-slots ((et:path) sun et:sockaddr-un)
 192     (let ((name (make-string (1- et:unix-path-max)))
 193           (abstract nil))
 194       (if (zerop (mem-aref path :uint8 0))
 195           ;; abstract address
 196           (progn
 197             (setf abstract t)
 198             (loop
 199                :for sindex :from 0 :below (1- et:unix-path-max)
 200                :for pindex :from 1 :below et:unix-path-max
 201                :do (setf (schar name sindex)
 202                          (code-char (mem-aref path :uint8 pindex)))))
 203           ;; address is in the filesystem
 204           (setf name (foreign-string-to-lisp path)))
 205       (make-instance 'unixaddr
 206                      :name name
 207                      :abstract abstract))))
 208
 209 (defun sockaddr-storage->netaddr (sa)
 210   (with-foreign-slots ((et:family) sa et:sockaddr-storage)
 211     (ecase family
 212       (#.et:af-inet
 213        (sockaddr-in->netaddr sa))
 214       (#.et:af-inet6
 215        (sockaddr-in6->netaddr sa))
 216       (#.et:af-local
 217        (sockaddr-un->netaddr sa)))))
 218
 219 (defun netaddr->sockaddr-storage (sa netaddr &optional (port 0))
 220   (etypecase netaddr
 221     (ipv4addr
 222      (make-sockaddr-in sa (name netaddr) port))
 223     (ipv6addr
 224      (make-sockaddr-in6 sa (name netaddr) port))
 225     (localaddr
 226      (make-sockaddr-un sa (name netaddr)))))