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 with-alien-saps ((&rest vars) &body body)
  28   `(sb-sys:with-pinned-objects ,(mapcar #'second vars)
  29      (let (,@(mapcar #'(lambda (pair)
  30                          `(,(first pair) (sb-alien:alien-sap ,(second pair))))
  31                      vars))
  32        ,@body)))
  33
  34 (defmacro with-pinned-aliens ((&rest vars) &body body)
  35   `(sb-alien:with-alien ,vars
  36      (sb-sys:with-pinned-objects ,(mapcar #'first vars)
  37        ,@body)))
  38
  39 (defmacro define-constant (name value &optional doc)
  40   `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
  41      ,@(when doc (list doc))))
  42
  43 (deftype ub8 () `(unsigned-byte 8))
  44 (deftype ub16 () `(unsigned-byte 16))
  45 (deftype ub32 () `(unsigned-byte 32))
  46 (deftype sb8 () `(signed-byte 8))
  47 (deftype sb16 () `(signed-byte 16))
  48 (deftype sb32 () `(signed-byte 32))
  49
  50 (defun string-or-parsed-number (val)
  51   (let ((tmpval val)
  52         type)
  53     (etypecase val
  54       (ub16
  55        (values :number val))
  56       (string
  57        (multiple-value-bind (parsed pos)
  58            (parse-integer val :junk-allowed t)
  59          (if (and parsed
  60                   (eql pos (length val))) ; the entire string is a number
  61              (progn
  62                (setf type :number)
  63                (setf tmpval parsed))
  64              (setf type :string))
  65          (values type tmpval))))))
  66
  67 (defun c->lisp-bool (val)
  68   (if (zerop val) nil t))
  69
  70 (defun lisp->c-bool (val)
  71   (if val 1 0))
  72
  73 (defmacro addrerr-value (keyword)
  74   `(et:alien-enum-value et:addrinfo-errors ,keyword))
  75
  76 (defmacro unixerr-value (keyword)
  77   `(et:alien-enum-value et:errno-values ,keyword))
  78
  79 ;;;
  80 ;;; Byte-swap functions
  81 ;;;
  82
  83 (defun htons (short)
  84 #+little-endian
  85   (let ((newshort 0))
  86     (declare (type ub16 newshort)
  87              (type ub16 short))
  88     (setf (ldb (byte 8 0) newshort) (ldb (byte 8 8) short))
  89     (setf (ldb (byte 8 8) newshort) (ldb (byte 8 0) short))
  90     newshort)
  91 #+big-endian short)
  92
  93 (defun ntohs (short)
  94   (htons short))
  95
  96 (defun htonl (long)
  97 #+little-endian
  98   (let ((newlong 0))
  99     (declare (type ub32 newlong)
 100              (type ub32 long))
 101     (setf (ldb (byte 8  0) newlong) (ldb (byte 8 24) long))
 102     (setf (ldb (byte 8 24) newlong) (ldb (byte 8  0) long))
 103     (setf (ldb (byte 8  8) newlong) (ldb (byte 8 16) long))
 104     (setf (ldb (byte 8 16) newlong) (ldb (byte 8  8) long))
 105     newlong)
 106 #+big-endian long)
 107
 108 (defun ntohl (long)
 109   (htonl long))
 110
 111 (defun copy-simple-array-ub16-to-alien-vector (lisp-vec alien-vec)
 112   (declare (type (simple-array ub16 (8)) lisp-vec)
 113            (type (alien (array et:uint16-t 8)) alien-vec))
 114   (dotimes (i 8)
 115     (setf (deref alien-vec i)
 116           (htons (aref lisp-vec i)))))
 117
 118 (defun map-ipv4-vector-to-ipv6 (addr)
 119   (declare (type (simple-array ub8 (*)) addr))
 120   (let ((ipv6addr (make-array 8 :element-type 'ub16
 121                                 :initial-element 0)))
 122     ;; setting the IPv4 marker
 123     (setf (aref ipv6addr 5) #xFFFF)
 124     ;; setting the first two bytes
 125     (setf (aref ipv6addr 6) (+ (ash (aref addr 0) 8)
 126                                (aref addr 1)))
 127     ;; setting the last two bytes
 128     (setf (aref ipv6addr 7) (+ (ash (aref addr 2) 8)
 129                                (aref addr 3)))
 130
 131     ipv6addr))
 132
 133 ;; From CLOCC's PORT library
 134 (defun vector-to-ipaddr (vector)
 135   (coerce vector '(simple-array ub8 (4)))
 136   (+ (ash (aref vector 0) 24)
 137      (ash (aref vector 1) 16)
 138      (ash (aref vector 2) 8)
 139      (aref vector 3)))
 140
 141 (defun make-sockaddr-in (sin ub8-vector &optional (port 0))
 142   (declare (type (alien (* et:sockaddr-in)) sin))
 143   (et:memset sin 0 et::size-of-sockaddr-in)
 144   (setf (slot sin 'et:family) et:af-inet)
 145   (setf (slot sin 'et:address) (htonl (vector-to-ipaddr ub8-vector)))
 146   (setf (slot sin 'et:port) (htons port))
 147   sin)
 148
 149 (defun make-sockaddr-in6 (sin6 ub16-vector &optional (port 0))
 150   (declare (type (alien (* et:sockaddr-in6)) sin6))
 151   (et:memset sin6 0 et::size-of-sockaddr-in6)
 152   (setf (slot sin6 'et:family) et:af-inet6)
 153   (let ((u16-vector (slot (slot (slot sin6 'et:address)
 154                                 'et:in6-u)
 155                           'et::addr16)))
 156     (copy-simple-array-ub16-to-alien-vector ub16-vector u16-vector)
 157     (setf (slot sin6 'et:port) (htons port)))
 158   sin6)
 159
 160 (defun make-sockaddr-un (sun string)
 161   (declare (type (alien (* et:sockaddr-un)) sun)
 162            (type string string))
 163   (et:memset sun 0 et::size-of-sockaddr-un)
 164   (setf (slot sun 'et:family) et:af-local)
 165   (let ((buff (sb-ext:string-to-octets string))
 166         (path (slot sun 'et:path)))
 167     (loop
 168        :for off :below (min (length buff)
 169                             (1- et:unix-path-max))
 170        :do (setf (deref path off) (aref buff off))))
 171   sun)
 172
 173 (defun make-vector-u8-4-from-in-addr (in-addr)
 174   (declare (type ub32 in-addr))
 175   (let ((vector (make-array 4 :element-type 'ub8)))
 176     (setf in-addr (ntohl in-addr))
 177     (setf (aref vector 0) (ldb (byte 8 24) in-addr))
 178     (setf (aref vector 1) (ldb (byte 8 16) in-addr))
 179     (setf (aref vector 2) (ldb (byte 8  8) in-addr))
 180     (setf (aref vector 3) (ldb (byte 8  0) in-addr))
 181
 182     vector))
 183
 184 (defun make-vector-u16-8-from-in6-addr (in6-addr)
 185   (declare (type (alien (* et:in6-addr)) in6-addr))
 186   (let ((newvector (make-array 8 :element-type 'ub16))
 187         (u16-vector (slot (slot in6-addr 'et:in6-u)
 188                           'et::addr16)))
 189     (dotimes (i 8)
 190       (setf (aref newvector i) (ntohs (deref u16-vector i))))
 191
 192     newvector))
 193
 194 (defun sockaddr-in->netaddr (sin)
 195   (declare (type (alien (* et:sockaddr-in)) sin))
 196   (make-address :ipv4 (make-vector-u8-4-from-in-addr
 197                        (slot sin 'et:address))))
 198
 199 (defun sockaddr-in6->netaddr (sin6)
 200   (declare (type (alien (* et:sockaddr-in6)) sin6))
 201   (make-address :ipv6 (make-vector-u16-8-from-in6-addr
 202                        (addr (slot sin6 'et:address)))))
 203
 204 (defun sockaddr-un->netaddr (sun)
 205   (declare (type (alien (* et:sockaddr-un)) sun))
 206   (let ((path (slot sun 'et:path))
 207         (name (make-string (1- et:unix-path-max)))
 208         (abstract nil))
 209     (if (zerop (deref path 0))
 210         ;; abstract address
 211         (progn
 212           (setf path (cast path (array (unsigned 8) 0)))
 213           (setf abstract t)
 214           (loop
 215              :for sindex :from 0 :below (1- et:unix-path-max)
 216              :for pindex :from 1 :below et:unix-path-max
 217              :do (setf (schar name sindex)
 218                        (code-char (deref path pindex)))))
 219         ;; address is in the filesystem
 220         (setf name (cast path c-string)))
 221     (make-instance 'localaddr
 222                    :name name
 223                    :abstract abstract)))
 224
 225 (defun sockaddr-storage->netaddr (sa)
 226   (declare (type (alien (* et:sockaddr-storage)) sa))
 227   (ecase (slot sa 'et:family)
 228     (#.et:af-inet
 229      (sockaddr-in->netaddr (cast sa (* et:sockaddr-in))))
 230     (#.et:af-inet6
 231      (sockaddr-in6->netaddr (cast sa (* et:sockaddr-in6))))
 232     (#.et:af-local
 233      (sockaddr-un->netaddr (cast sa (* et:sockaddr-un))))))
 234
 235 (defun netaddr->sockaddr-storage (sa netaddr &optional (port 0))
 236   (declare (type (alien (* et:sockaddr-storage)) sa))
 237   (ecase (slot sa 'et:family)
 238     (#.et:af-inet
 239      (make-sockaddr-in (cast sa (* et:sockaddr-in))
 240                        (name netaddr) port))
 241     (#.et:af-inet6
 242      (make-sockaddr-in6 (cast sa (* et:sockaddr-in6))
 243                         (name netaddr) port))
 244     (#.et:af-local
 245      (make-sockaddr-un (cast sa (* et:sockaddr-un))
 246                        (name netaddr)))))