source: trunk/src/async-socket.lisp

Last change on this file was 6, checked in by psmith, 16 years ago

Moved to standard directory structure

File size: 5.8 KB
Line 
1#|
2Copyright (c) 2006 Risto Laakso
3All rights reserved.
4
5Redistribution and use in source and binary forms, with or without
6modification, are permitted provided that the following conditions
7are met:
81. Redistributions of source code must retain the above copyright
9   notice, this list of conditions and the following disclaimer.
102. 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.
133. 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
16THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
17IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
18OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
19IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
20INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
22DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
24(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
25THIS 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
Note: See TracBrowser for help on using the repository browser.