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 | (defun trivial-accept (client) |
---|
32 | (declare (ignore client)) |
---|
33 | ;; (format t "Accepting connection from ~S:~D [~A].~%" host port proto) |
---|
34 | t) |
---|
35 | |
---|
36 | ;TODO thread safety |
---|
37 | (defparameter +connected-sockets+ nil |
---|
38 | "List of sockets that have been connected and are awaiting addition to the event-notification system") |
---|
39 | |
---|
40 | ;loop over hashtable |
---|
41 | (defun process-async-fds (client-hash) |
---|
42 | (maphash #'(lambda (k async-fd) |
---|
43 | (format-log t "Dealing with ~a => ~a~%" k async-fd) |
---|
44 | |
---|
45 | ;process reads |
---|
46 | (when (read-ready async-fd) (read-more async-fd)) |
---|
47 | (when (> (buffer-position (foreign-read-buffer async-fd)) 0) |
---|
48 | (process-read async-fd)) |
---|
49 | |
---|
50 | ;process-writes |
---|
51 | (process-write async-fd) |
---|
52 | (when (and (write-ready async-fd) |
---|
53 | (> (buffer-position (foreign-write-buffer async-fd)) 0)) |
---|
54 | (write-more async-fd))) |
---|
55 | client-hash)) |
---|
56 | |
---|
57 | |
---|
58 | |
---|
59 | |
---|
60 | (defun start-server (connection-handler accept-filter connection-type |
---|
61 | &key |
---|
62 | (protocol :inet) |
---|
63 | (port (+ (random 60000) 1024)) |
---|
64 | (host "localhost") |
---|
65 | (accept-connection #'trivial-accept)) |
---|
66 | |
---|
67 | |
---|
68 | (let (sock |
---|
69 | (event-queue (make-event-queue)) |
---|
70 | (client-hash (make-hash-table :test 'eql)) |
---|
71 | ) |
---|
72 | |
---|
73 | (setq sock (ecase protocol |
---|
74 | (:inet (make-inet-socket)) |
---|
75 | (:inet6 (make-inet6-socket)))) |
---|
76 | |
---|
77 | (unless (ecase protocol |
---|
78 | (:inet (bind-inet-socket sock port host)) |
---|
79 | (:inet6 (bind-inet6-socket sock port host))) |
---|
80 | (error "Can't bind socket!")) |
---|
81 | |
---|
82 | (set-fd-nonblocking sock) |
---|
83 | |
---|
84 | (format t "~&Starting server on ~S port ~S.. (socket fd is ~D)~%" host port sock) |
---|
85 | |
---|
86 | (start-listen sock) |
---|
87 | |
---|
88 | (add-fd event-queue sock :read :trigger :level) |
---|
89 | |
---|
90 | (format t "waiting for events..~%") (force-output) |
---|
91 | |
---|
92 | (catch 'poll-error-exit |
---|
93 | (handler-bind ((poll-error #'(lambda (cond) |
---|
94 | (declare (ignore cond)) |
---|
95 | (format t "Poll-error (errno ~A), exiting..~%" (get-errno)) |
---|
96 | (throw 'poll-error-exit nil)))) |
---|
97 | |
---|
98 | (loop |
---|
99 | (let ((unix-epoll-events (poll-events event-queue))) |
---|
100 | (loop for (fd . event) in unix-epoll-events do |
---|
101 | (cond |
---|
102 | ;; new connection |
---|
103 | ((= fd sock) |
---|
104 | (let ((async-fd (socket-accept fd connection-type))) |
---|
105 | #+nio-debug (format t "start-server - New conn: ~A~%" async-fd) |
---|
106 | (cond |
---|
107 | ((null async-fd) |
---|
108 | (format t "Accept failed.~%")) |
---|
109 | |
---|
110 | ;; accept connection ? |
---|
111 | ((funcall accept-connection async-fd) |
---|
112 | (set-fd-nonblocking (async-fd-read-fd async-fd)) |
---|
113 | (setf (gethash (async-fd-read-fd async-fd) client-hash) async-fd) |
---|
114 | (add-async-fd event-queue async-fd :read-write) |
---|
115 | ; (add-async-fd event-queue async-fd :write) |
---|
116 | ) |
---|
117 | |
---|
118 | ;; no accept, close |
---|
119 | (t |
---|
120 | (format-log t "start-server - accept-connection closed~%") |
---|
121 | (close-async-fd async-fd))))) |
---|
122 | |
---|
123 | |
---|
124 | ;; socket i/o available |
---|
125 | (t |
---|
126 | (let ((async-fd (gethash fd client-hash))) |
---|
127 | (format-log t "IO event ~A on ~A~%" event async-fd) |
---|
128 | (unless (null async-fd) |
---|
129 | (catch 'error-exit |
---|
130 | (handler-bind ((read-error #'(lambda (x) |
---|
131 | (declare (ignore x)) |
---|
132 | (format t "read-error, dropping ~A.~%" async-fd) |
---|
133 | (setf (gethash (async-fd-read-fd async-fd) client-hash) nil) |
---|
134 | (remove-async-fd event-queue async-fd :read) |
---|
135 | (remove-async-fd event-queue async-fd :write) |
---|
136 | (force-close-async-fd async-fd) |
---|
137 | (throw 'error-exit nil)))) |
---|
138 | |
---|
139 | (when (read-event-p event) (setf (read-ready async-fd) t)) |
---|
140 | (when (write-event-p event) (setf (write-ready async-fd) t))))))))) |
---|
141 | |
---|
142 | ;add outgoing sockets to event queue |
---|
143 | (format-log t "nio-server:start-server - Processing client add ~A~%" +connected-sockets+) |
---|
144 | (loop for new-fd in +connected-sockets+ do |
---|
145 | (format-log t "nio-server:start-server - Dealing with ~A~%" new-fd) |
---|
146 | (setf (gethash (async-fd-read-fd new-fd) client-hash) new-fd) |
---|
147 | (add-async-fd event-queue new-fd :read-write)) |
---|
148 | |
---|
149 | ;TODO thread safety |
---|
150 | (setf +connected-sockets+ nil) |
---|
151 | |
---|
152 | ;loop over async-fd's processing where necessary |
---|
153 | (process-async-fds client-hash) |
---|
154 | )))) |
---|
155 | (ignore-errors |
---|
156 | (close-fd sock)))) |
---|
157 | |
---|
158 | |
---|
159 | (defun add-connection (host port connection-type |
---|
160 | &key |
---|
161 | (protocol :inet) |
---|
162 | |
---|
163 | ) |
---|
164 | (let ((sock nil)) |
---|
165 | (setq sock (ecase protocol |
---|
166 | (:inet (make-inet-socket)) |
---|
167 | (:inet6 (make-inet6-socket)))) |
---|
168 | |
---|
169 | (if (connect-inet-socket sock host port) |
---|
170 | (let ((sm (create-state-machine connection-type sock sock sock))) |
---|
171 | (push sm +connected-sockets+) |
---|
172 | (format-log t "nio-server:add-connection - Socket enqueued: ~A~%" +connected-sockets+) |
---|
173 | (return-from add-connection sm)) |
---|
174 | (format t "Connect failed!!~A ~%" (get-errno))))) |
---|
175 | |
---|