1 | #| |
---|
2 | Copyright (c) 2006 Risto Laakso |
---|
3 | All rights reserved. |
---|
4 | |
---|
5 | Redistribution and use in source and binary forms, with or without |
---|
6 | modification, are permitted provided that the following conditions |
---|
7 | are met: |
---|
8 | 1. Redistributions of source code must retain the above copyright |
---|
9 | notice, this list of conditions and the following disclaimer. |
---|
10 | 2. Redistributions in binary form must reproduce the above copyright |
---|
11 | notice, this list of conditions and the following disclaimer in the |
---|
12 | documentation and/or other materials provided with the distribution. |
---|
13 | 3. The name of the author may not be used to endorse or promote products |
---|
14 | derived from this software without specific prior written permission. |
---|
15 | |
---|
16 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR |
---|
17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES |
---|
18 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. |
---|
19 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, |
---|
20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT |
---|
21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, |
---|
22 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
23 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
---|
24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF |
---|
25 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
26 | |# |
---|
27 | (in-package :nio) |
---|
28 | |
---|
29 | (declaim (optimize (debug 3) (speed 3) (space 0))) |
---|
30 | |
---|
31 | ;;;; FFI |
---|
32 | |
---|
33 | (defconstant +af-inet+ 2) |
---|
34 | (defconstant +af-inet6+ 30) |
---|
35 | |
---|
36 | (defconstant +sock-stream+ 1) |
---|
37 | (defconstant +sock-dgram+ 2) |
---|
38 | |
---|
39 | (defcstruct sockaddr-in |
---|
40 | (len :uint8) |
---|
41 | (family :uint8) |
---|
42 | (port :uint16) |
---|
43 | (addr :uint32) |
---|
44 | (zero :char :count 8)) |
---|
45 | |
---|
46 | (defconstant +sockaddr-in-len+ #.(+ 1 1 2 4 8)) |
---|
47 | |
---|
48 | (defcstruct sockaddr-in6 |
---|
49 | (len :uint8) |
---|
50 | (family :uint8) |
---|
51 | (port :uint16) |
---|
52 | (flowinfo :uint32) |
---|
53 | (addr :uint16 :count 8) |
---|
54 | (scope-id :uint32)) |
---|
55 | |
---|
56 | (defconstant +sockaddr-in6-len+ #.(+ 1 1 2 4 16 4)) |
---|
57 | |
---|
58 | (defcfun ("socket" %socket) :int |
---|
59 | (domain :int) |
---|
60 | (type :int) |
---|
61 | (protocol :int)) |
---|
62 | |
---|
63 | (defcfun ("inet_pton" %inet-pton) :int |
---|
64 | (af :int) |
---|
65 | (src :string) |
---|
66 | (dst :pointer)) |
---|
67 | |
---|
68 | (defcfun ("htons" %htons) :uint16 |
---|
69 | (host-value :uint16)) |
---|
70 | |
---|
71 | (defcfun ("bind" %bind) :int |
---|
72 | (socket :int) |
---|
73 | (sockaddr :pointer) |
---|
74 | (socklent :long)) |
---|
75 | |
---|
76 | (defcfun ("listen" %listen) :int |
---|
77 | (socket :int) |
---|
78 | (backlog :int)) |
---|
79 | |
---|
80 | (defcfun ("accept" %accept) :int |
---|
81 | (socket :int) |
---|
82 | (sockaddr :pointer) |
---|
83 | (socklen :pointer)) |
---|
84 | |
---|
85 | |
---|
86 | (defun start-listen (socket-fd &optional (backlog 7)) |
---|
87 | (%listen socket-fd backlog)) |
---|
88 | |
---|
89 | |
---|
90 | ;;;; IPv4 |
---|
91 | |
---|
92 | (defun make-inet-socket (&optional (type :tcp)) |
---|
93 | (%socket +af-inet+ (ecase type (:tcp +sock-stream+) (:udp +sock-dgram+)) 0)) |
---|
94 | |
---|
95 | (defun bind-inet-socket (socket-fd port &optional (addr "127.0.0.1")) |
---|
96 | (with-foreign-object (sa 'sockaddr-in) |
---|
97 | |
---|
98 | (memzero sa +sockaddr-in-len+) |
---|
99 | |
---|
100 | ;; init struct |
---|
101 | (setf (foreign-slot-value sa 'sockaddr-in 'len) +sockaddr-in-len+ |
---|
102 | (foreign-slot-value sa 'sockaddr-in 'port) (%htons port) |
---|
103 | (foreign-slot-value sa 'sockaddr-in 'family) +af-inet+) |
---|
104 | |
---|
105 | ;; set addr |
---|
106 | (if (/= (%inet-pton +af-inet+ addr (foreign-slot-pointer sa 'sockaddr-in 'addr)) 1) |
---|
107 | (error "inet_pton: Bad address ~A!" addr)) |
---|
108 | |
---|
109 | ;; bind |
---|
110 | (if (= (%bind socket-fd sa +sockaddr-in-len+) 0) |
---|
111 | t |
---|
112 | nil))) |
---|
113 | |
---|
114 | |
---|
115 | ;;;; IPv6 |
---|
116 | |
---|
117 | (defun make-inet6-socket (&optional (type :tcp)) |
---|
118 | (%socket +af-inet6+ (ecase type (:tcp +sock-stream+) (:udp +sock-dgram+)) 0)) |
---|
119 | |
---|
120 | (defun bind-inet6-socket (socket-fd port &optional (addr "::1")) |
---|
121 | (with-foreign-object (sa 'sockaddr-in6) |
---|
122 | |
---|
123 | (memzero sa +sockaddr-in6-len+) |
---|
124 | |
---|
125 | ;; init struct |
---|
126 | (setf (foreign-slot-value sa 'sockaddr-in6 'len) +sockaddr-in6-len+ |
---|
127 | (foreign-slot-value sa 'sockaddr-in6 'port) (%htons port) |
---|
128 | (foreign-slot-value sa 'sockaddr-in6 'family) +af-inet6+) |
---|
129 | |
---|
130 | ;; set addr |
---|
131 | (if (/= (%inet-pton +af-inet6+ addr (foreign-slot-pointer sa 'sockaddr-in6 'addr)) 1) |
---|
132 | (error "inet_pton: Bad address ~A!" addr)) |
---|
133 | |
---|
134 | ;; bind |
---|
135 | (if (= (%bind socket-fd sa +sockaddr-in6-len+) 0) |
---|
136 | t |
---|
137 | nil))) |
---|
138 | |
---|
139 | |
---|
140 | |
---|
141 | ;;;; SOCKET I/O |
---|
142 | |
---|
143 | (defclass async-socket-fd (async-fd) |
---|
144 | ((family :initform :unknown :initarg :family) |
---|
145 | (remote-host :initform nil :initarg :remote-host) |
---|
146 | (remote-port :initform nil :initarg :remote-port))) |
---|
147 | |
---|
148 | |
---|
149 | (defun socket-accept (socket-fd) |
---|
150 | "Accept connection from SOCKET-FD. Allocates and returns socket structure denoting the connection." |
---|
151 | |
---|
152 | (flet ((parse-inet6-addr (addr) |
---|
153 | (let ((client-addr (foreign-slot-value addr 'sockaddr-in6 'addr))) |
---|
154 | (loop for i from 0 to 7 |
---|
155 | for hex = (mem-aref client-addr :unsigned-short i) |
---|
156 | collect hex into res |
---|
157 | finally (return res)))) |
---|
158 | |
---|
159 | (parse-inet4-addr (addr) |
---|
160 | (let ((client-addr (foreign-slot-value addr 'sockaddr-in 'addr))) |
---|
161 | (loop for i from 0 to 3 |
---|
162 | for hex = (logand (ash client-addr (- (* i 8))) #xFF) |
---|
163 | collect hex into res |
---|
164 | finally (return (nreverse res)))))) |
---|
165 | |
---|
166 | (with-foreign-object (addr 'sockaddr-in6) |
---|
167 | |
---|
168 | (let ((len (foreign-alloc :unsigned-long :initial-element +sockaddr-in6-len+))) |
---|
169 | |
---|
170 | ;; accept connection |
---|
171 | (let* ((res (%accept socket-fd addr len)) |
---|
172 | (async-socket-fd (make-instance 'async-socket-fd :read-fd res :write-fd res))) |
---|
173 | |
---|
174 | (unless (< res 0) |
---|
175 | (let ((len-value (mem-ref len :unsigned-int))) |
---|
176 | |
---|
177 | ;; parse sockaddr struct for remote client info |
---|
178 | |
---|
179 | (with-slots (family remote-host remote-port) async-socket-fd |
---|
180 | |
---|
181 | (cond |
---|
182 | ((= len-value +sockaddr-in6-len+) |
---|
183 | (setf family :inet6 |
---|
184 | remote-port (foreign-slot-value addr 'sockaddr-in6 'port) |
---|
185 | remote-host (parse-inet6-addr addr))) |
---|
186 | |
---|
187 | ((= len-value +sockaddr-in-len+) |
---|
188 | (setf family :inet4 |
---|
189 | remote-port (foreign-slot-value addr 'sockaddr-in 'port) |
---|
190 | remote-host (parse-inet4-addr addr))))) |
---|
191 | |
---|
192 | |
---|
193 | (foreign-free len) |
---|
194 | (if (>= res 0) async-socket-fd nil) |
---|
195 | ))))))) |
---|
196 | |
---|
197 | |
---|
198 | (defun remote-info (async-socket-fd) |
---|
199 | "Return FAMILY, REMOTE-HOST and REMOTE-PORT in list." |
---|
200 | (with-slots (family remote-host remote-port) async-socket-fd |
---|
201 | (list family remote-host remote-port))) |
---|
202 | |
---|