1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; winsock.lisp --- CFFI bindings specific to Winsock.
5 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
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:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
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.
27 (in-package :net.sockets
)
29 (defctype dword
:unsigned-long
)
30 (defctype word
:unsigned-short
)
31 (defctype group
:unsigned-int
)
33 (osicat-posix::defsyscall
"get_osfhandle" :int
36 (osicat-posix::defsyscall
"open_osfhandle" :int
40 (defconstant invalid-socket
(1- (expt 2 32)))
42 (deforeign ("WSASocketA" wsa-socket
)
43 (errno-wrapper :int
:error-predicate
(lambda (x) (eql x invalid-socket
)))
47 (protocol-info :pointer
)
51 (defun socket (af type proto
)
52 (open-osfhandle (wsa-socket af type proto
(null-pointer) 0 0) 0))
54 (define-socket-call ("WSAStringToAddressA" wsa-string-to-address
) :int
55 (address-string :string
)
57 (protocol-info :pointer
)
59 (address-length (:pointer
:int
)))
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)
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.")
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.")))
164 ;;; not actually used (yet?)
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
))
174 (define-socket-call ("WSAStartup" %wsa-startup
) :int
175 (version-requested word
)
178 (defun wsa-startup (version-requested)
179 (with-foreign-object (data 'wsa-data
)
180 (%wsa-startup version-requested data
)))
182 (defun make-wsa-version (major minor
)
183 (dpb minor
(byte 8 8) major
))
185 (defvar *wsa-startup-call
* (wsa-startup (make-wsa-version 2 2)))
189 (defconstant max-hostname-len
128)
190 (defconstant max-domain-name-len
128)
191 (defconstant max-scope-id-len
256)
193 (defcstruct ip-address-string
194 (string :char
:count
#.
(* 4 4)))
196 (defctype ip-mask-string ip-address-string
)
198 (defcstruct ip-addr-string
200 (ip-address ip-address-string
)
201 (ip-mask ip-mask-string
)
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
)
210 (scope-id :char
:count
#.
(+ max-scope-id-len
4))
211 (enable-routing :uint
)
215 (load-foreign-library "Iphlpapi.dll")
217 (deforeign ("GetNetworkParams" %get-network-params
) dword
218 (fixed-info fixed-info
)
219 (out-buf-len (:pointer
:ulong
)))
221 (defconstant error-success
0)
222 (defconstant error-buffer-overflow
111)
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
)))
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
)))))