sockets/winsock.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; winsock.lisp --- CFFI bindings specific to Winsock.
   4 ;;;
   5 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26
  27 (in-package :net.sockets)
  28
  29 (defctype dword :unsigned-long)
  30 (defctype word :unsigned-short)
  31 (defctype group :unsigned-int)
  32
  33 (osicat-posix::defsyscall "get_osfhandle" :int
  34   (fd :int))
  35
  36 (osicat-posix::defsyscall "open_osfhandle" :int
  37   (handle :intptr)
  38   (flags :int))
  39
  40 (defconstant invalid-socket (1- (expt 2 32)))
  41
  42 (deforeign ("WSASocketA" wsa-socket)
  43     (errno-wrapper :int :error-predicate (lambda (x) (eql x invalid-socket)))
  44   (af :int)
  45   (type :int)
  46   (protocol :int)
  47   (protocol-info :pointer)
  48   (g group)
  49   (flags dword))
  50
  51 (defun socket (af type proto)
  52   (open-osfhandle (wsa-socket af type proto (null-pointer) 0 0) 0))
  53
  54 (define-socket-call ("WSAStringToAddressA" wsa-string-to-address) :int
  55   (address-string :string)
  56   (address-family :int)
  57   (protocol-info :pointer)
  58   (address :pointer)
  59   (address-length (:pointer :int)))
  60
  61 ;;; It's pretty strange that I can't seem to find something equivalent
  62 ;;; to strerror().  Thank god for keyboard macros though.
  63 ;;; From <http://msdn2.microsoft.com/en-us/library/ms740668.aspx>
  64 (defun get-wsa-error-string (code)
  65   (case code
  66     (6 "Specified event object handle is invalid.") ; WSA_INVALID_HANDLE
  67     (8 "Insufficient memory available.") ; WSA_NOT_ENOUGH_MEMORY
  68     (87 "One or more parameters are invalid.") ; WSA_INVALID_PARAMETER
  69     (995 "Overlapped operation aborted.") ; WSA_OPERATION_ABORTED
  70     (996 "Overlapped I/O event object not in signaled state.")
  71                                         ; WSA_IO_INCOMPLETE
  72     (997 "Overlapped operations will complete later.") ; WSA_IO_PENDING
  73     (10004 "Interrupted function call.") ; WSAEINTR
  74     (10009 "File handle is not valid.") ; WSAEBADF
  75     (10013 "Permission denied.")        ; WSAEACCES
  76     (10014 "Bad address.")              ; WSAEFAULT
  77     (10022 "Invalid argument.")         ; WSAEINVAL
  78     (10024 "Too many open sockets.")    ; WSAEMFILE
  79     (10035 "Resource temporarily unavailable.") ; WSAEWOULDBLOCK
  80     (10036 "Operation now in progress.") ; WSAEINPROGRESS
  81     (10037 "Operation already in progress.") ; WSAEALREADY
  82     (10038 "Socket operation on nonsocket.") ; WSAENOTSOCK
  83     (10039 "Destination address required.") ; WSAEDESTADDRREQ
  84     (10040 "Message too long.")         ; WSAEMSGSIZE
  85     (10041 "Protocol wrong type for socket.") ; WSAEPROTOTYPE
  86     (10042 "Bad protocol option.")      ; WSAENOPROTOOPT
  87     (10043 "Protocol not supported.")   ; WSAEPROTONOSUPPORT
  88     (10044 "Socket type not supported.") ; WSAESOCKTNOSUPPORT
  89     (10045 "Operation not supported.")  ; WSAEOPNOTSUPP
  90     (10046 "Protocol family not supported.") ; WSAEPFNOSUPPORT
  91     (10047 "Address family not supported by protocol family.") ; WSAEAFNOSUPPORT
  92     (10048 "Address already in use.")   ; WSAEADDRINUSE
  93     (10049 "Cannot assign requested address.") ; WSAEADDRNOTAVAIL
  94     (10050 "Network is down.")          ; WSAENETDOWN
  95     (10051 "Network is unreachable.")   ; WSAENETUNREACH
  96     (10052 "Network dropped connection on reset.") ; WSAENETRESET
  97     (10053 "Software caused connection abort.") ; WSAECONNABORTED
  98     (10054 "Connection reset by peer.") ; WSAECONNRESET
  99     (10055 "No buffer space available.") ; WSAENOBUFS
 100     (10056 "Socket is already connected.") ; WSAEISCONN
 101     (10057 "Socket is not connected.")  ; WSAENOTCONN
 102     (10058 "Cannot send after socket shutdown.") ; WSAESHUTDOWN
 103     (10059 "Too many references.")      ; WSAETOOMANYREFS
 104     (10060 "Connection timed out.")     ; WSAETIMEDOUT
 105     (10061 "Connection refused.")       ; WSAECONNREFUSED
 106     (10062 "Cannot translate name.")    ; WSAELOOP
 107     (10063 "Name too long.")            ; WSAENAMETOOLONG
 108     (10064 "Host is down.")             ; WSAEHOSTDOWN
 109     (10065 "No route to host.")         ; WSAEHOSTUNREACH
 110     (10066 "Directory not empty.")      ; WSAENOTEMPTY
 111     (10067 "Too many processes.")       ; WSAEPROCLIM
 112     (10068 "User quota exceeded.")      ; WSAEUSERS
 113     (10069 "Disk quota exceeded.")      ; WSAEDQUOT
 114     (10070 "Stale file handle reference.") ; WSAESTALE
 115     (10071 "Item is remote.")           ; WSAEREMOTE
 116     (10091 "Network subsystem is unavailable.") ; WSASYSNOTREADY
 117     (10092 "Winsock.dll version out of range.") ; WSAVERNOTSUPPORTED
 118     (10093 "Successful WSAStartup not yet performed.") ; WSANOTINITIALISED
 119     (10101 "Graceful shutdown in progress.") ; WSAEDISCON
 120     (10102 "No more results.")          ; WSAENOMORE
 121     (10103 "Call has been canceled.")   ; WSAECANCELLED
 122     (10104 "Procedure call table is invalid.") ; WSAEINVALIDPROCTABLE
 123     (10105 "Service provider is invalid.") ; WSAEINVALIDPROVIDER
 124     (10106 "Service provider failed to initialize.") ; WSAEPROVIDERFAILEDINIT
 125     (10107 "System call failure.")      ; WSASYSCALLFAILURE
 126     (10108 "Service not found.")        ; WSASERVICE_NOT_FOUND
 127     (10109 "Class type not found.")     ; WSATYPE_NOT_FOUND
 128     (10110 "No more results.")          ; WSA_E_NO_MORE
 129     (10111 "Call was canceled.")        ; WSA_E_CANCELLED
 130     (10112 "Database query was refused.") ; WSAEREFUSED
 131     (11001 "Host not found.")           ; WSAHOST_NOT_FOUND
 132     (11002 "Nonauthoritative host not found.") ; WSATRY_AGAIN
 133     (11003 "This is a nonrecoverable error.") ; WSANO_RECOVERY
 134     (11004 "Valid name, no data record of requested type.") ; WSANO_DATA
 135     (11005 "QOS receivers.")            ; WSA_QOS_RECEIVERS
 136     (11006 "QOS senders.")              ; WSA_QOS_SENDERS
 137     (11007 "No QOS senders.")           ; WSA_QOS_NO_SENDERS
 138     (11008 "QOS no receivers.")         ; WSA_QOS_NO_RECEIVERS
 139     (11009 "QOS request confirmed.")    ; WSA_QOS_REQUEST_CONFIRMED
 140     (11010 "QOS admission error.")      ; WSA_QOS_ADMISSION_FAILURE
 141     (11011 "QOS policy failure.")       ; WSA_QOS_POLICY_FAILURE
 142     (11012 "QOS bad style.")            ; WSA_QOS_BAD_STYLE
 143     (11013 "QOS bad object.")           ; WSA_QOS_BAD_OBJECT
 144     (11014 "QOS traffic control error.") ; WSA_QOS_TRAFFIC_CTRL_ERROR
 145     (11015 "QOS generic error.")        ; WSA_QOS_GENERIC_ERROR
 146     (11016 "QOS service type error.")   ; WSA_QOS_ESERVICETYPE
 147     (11017 "QOS flowspec error.")       ; WSA_QOS_EFLOWSPEC
 148     (11018 "Invalid QOS provider buffer.") ; WSA_QOS_EPROVSPECBUF
 149     (11019 "Invalid QOS filter style.") ; WSA_QOS_EFILTERSTYLE
 150     (11020 "Invalid QOS filter type.")  ; WSA_QOS_EFILTERTYPE
 151     (11021 "Incorrect QOS filter count.") ; WSA_QOS_EFILTERCOUNT
 152     (11022 "Invalid QOS object length.") ; WSA_QOS_EOBJLENGTH
 153     (11023 "Incorrect QOS flow count.") ; WSA_QOS_EFLOWCOUNT
 154     (11024 "Unrecognized QOS object.")  ; WSA_QOS_EUNKOWNPSOBJ
 155     (11025 "Invalid QOS policy object.") ; WSA_QOS_EPOLICYOBJ
 156     (11026 "Invalid QOS flow descriptor.") ; WSA_QOS_EFLOWDESC
 157     (11027 "Invalid QOS provider-specific flowspec.") ; WSA_QOS_EPSFLOWSPEC
 158     (11028 "Invalid QOS provider-specific filterspec.") ; WSA_QOS_EPSFILTERSPEC
 159     (11029 "Invalid QOS shape discard mode object.") ; WSA_QOS_ESDMODEOBJ
 160     (11030 "Invalid QOS shaping rate object.") ; WSA_QOS_ESHAPERATEOBJ
 161     (11031 "Reserved policy QOS element type.") ; WSA_QOS_RESERVED_PETYPE
 162     (t "Unknown Winsock error.")))
 163
 164 ;;; not actually used (yet?)
 165 (defcstruct wsa-data
 166   (version word)
 167   (high-version word)
 168   (description :char :count 257)
 169   (system-status :char :count 129)
 170   (max-sockets :unsigned-short)
 171   (max-udp-dg :unsigned-short)
 172   (vendor-info :string))
 173
 174 (define-socket-call ("WSAStartup" %wsa-startup) :int
 175   (version-requested word)
 176   (data wsa-data))
 177
 178 (defun wsa-startup (version-requested)
 179   (with-foreign-object (data 'wsa-data)
 180     (%wsa-startup version-requested data)))
 181
 182 (defun make-wsa-version (major minor)
 183   (dpb minor (byte 8 8) major))
 184
 185 (defvar *wsa-startup-call* (wsa-startup (make-wsa-version 2 2)))
 186
 187 ;;;; Network Info
 188
 189 (defconstant max-hostname-len 128)
 190 (defconstant max-domain-name-len 128)
 191 (defconstant max-scope-id-len 256)
 192
 193 (defcstruct ip-address-string
 194   (string :char :count #.(* 4 4)))
 195
 196 (defctype ip-mask-string ip-address-string)
 197
 198 (defcstruct ip-addr-string
 199   (next :pointer)
 200   (ip-address ip-address-string)
 201   (ip-mask ip-mask-string)
 202   (context dword))
 203
 204 (defcstruct fixed-info
 205   (host-name :char :count #.(+ max-hostname-len 4))
 206   (domain-name :char :count #.(+ max-domain-name-len 4))
 207   (current-dns-server (:pointer ip-addr-string))
 208   (dns-server-list ip-addr-string)
 209   (node-type :uint)
 210   (scope-id :char :count #.(+ max-scope-id-len 4))
 211   (enable-routing :uint)
 212   (enable-proxy :uint)
 213   (enable-dns :uint))
 214
 215 (load-foreign-library "Iphlpapi.dll")
 216
 217 (deforeign ("GetNetworkParams" %get-network-params) dword
 218   (fixed-info fixed-info)
 219   (out-buf-len (:pointer :ulong)))
 220
 221 (defconstant error-success 0)
 222 (defconstant error-buffer-overflow 111)
 223
 224 ;;; just getting the DNS servers for now.
 225 (defun get-first-dns-server ()
 226   (with-foreign-object (len :ulong)
 227     (assert (eql error-buffer-overflow
 228                  (%get-network-params (null-pointer) len)))
 229     (with-foreign-pointer (ptr (mem-ref len :ulong))
 230       (assert (eql error-success (%get-network-params ptr len)))
 231       (values
 232        (foreign-string-to-lisp
 233         (foreign-slot-pointer (foreign-slot-value
 234                                ptr 'fixed-info 'dns-server-list)
 235                               'ip-addr-string 'ip-address)
 236         :encoding :ascii)))))