[1] | 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 | (defpackage :nio-server (:use :cl :nio :event-notification) |
---|
| 28 | (:export start-server)) |
---|
| 29 | (in-package :nio-server) |
---|
| 30 | |
---|
| 31 | (declaim (optimize (debug 3) (speed 3) (space 0))) |
---|
| 32 | |
---|
| 33 | (defun trivial-accept (client) |
---|
| 34 | (declare (ignore client)) |
---|
| 35 | ;; (format t "Accepting connection from ~S:~D [~A].~%" host port proto) |
---|
| 36 | t) |
---|
| 37 | |
---|
| 38 | (defun start-server (connection-handler accept-filter &key |
---|
| 39 | (protocol :inet) (port (+ (random 60000) 1024)) (host "localhost") |
---|
| 40 | (accept-connection #'trivial-accept)) |
---|
| 41 | |
---|
| 42 | |
---|
| 43 | (let (sock |
---|
| 44 | (event-queue (make-event-queue)) |
---|
| 45 | (client-hash (make-hash-table :test 'eql)) |
---|
| 46 | ) |
---|
| 47 | |
---|
| 48 | (setq sock (ecase protocol |
---|
| 49 | (:inet (make-inet-socket)) |
---|
| 50 | (:inet6 (make-inet6-socket)))) |
---|
| 51 | |
---|
| 52 | (unless (ecase protocol |
---|
| 53 | (:inet (bind-inet-socket sock port host)) |
---|
| 54 | (:inet6 (bind-inet6-socket sock port host))) |
---|
| 55 | (error "Can't bind socket!")) |
---|
| 56 | |
---|
| 57 | (set-fd-nonblocking sock) |
---|
| 58 | |
---|
| 59 | (format t "~&Starting server on ~S port ~S.. (socket fd is ~D)~%" host port sock) |
---|
| 60 | |
---|
| 61 | (start-listen sock) |
---|
[10] | 62 | |
---|
| 63 | (add-fd event-queue sock :read :trigger :level) |
---|
[1] | 64 | |
---|
| 65 | (format t "waiting for events..~%") (force-output) |
---|
| 66 | |
---|
| 67 | (catch 'poll-error-exit |
---|
| 68 | (handler-bind ((poll-error #'(lambda (cond) |
---|
| 69 | (declare (ignore cond)) |
---|
| 70 | (format t "Poll-error, exiting..~%") |
---|
| 71 | (throw 'poll-error-exit nil)))) |
---|
| 72 | |
---|
[10] | 73 | (loop for unix-epoll-events = (poll-events event-queue) do |
---|
[1] | 74 | |
---|
[10] | 75 | (loop for (fd . event) in unix-epoll-events do |
---|
[1] | 76 | (cond |
---|
| 77 | |
---|
| 78 | ;; new connection |
---|
| 79 | ((= fd sock) |
---|
| 80 | (let ((async-fd (socket-accept fd))) |
---|
[10] | 81 | #+nio-debug (format t "start-server - New conn: ~A~%" async-fd) |
---|
[1] | 82 | (cond |
---|
| 83 | ((null async-fd) |
---|
| 84 | (format t "Accept failed.~%")) |
---|
| 85 | |
---|
| 86 | ;; accept connection ? |
---|
[10] | 87 | ((set-fd-nonblocking (async-fd-read-fd async-fd)) |
---|
| 88 | (funcall accept-connection async-fd) |
---|
[1] | 89 | (setf (gethash (async-fd-read-fd async-fd) client-hash) async-fd) |
---|
| 90 | (set-accept-filter async-fd accept-filter) |
---|
| 91 | (set-read-callback async-fd connection-handler) |
---|
[10] | 92 | (add-async-fd event-queue async-fd :read-write) |
---|
| 93 | ; (add-async-fd event-queue async-fd :write) |
---|
[1] | 94 | ) |
---|
| 95 | |
---|
| 96 | ;; no accept, close |
---|
| 97 | (t |
---|
[10] | 98 | (format t "start-server - accept-connection closed~%") |
---|
[1] | 99 | (close-async-fd async-fd))))) |
---|
| 100 | |
---|
| 101 | |
---|
| 102 | ;; socket i/o available |
---|
| 103 | (t |
---|
| 104 | (let ((async-fd (gethash fd client-hash))) |
---|
[10] | 105 | #+nio-debug (format t "IO event ~A on ~A~%" event async-fd) |
---|
[1] | 106 | (unless (null async-fd) |
---|
| 107 | (catch 'error-exit |
---|
| 108 | (handler-bind ((read-error #'(lambda (x) |
---|
| 109 | (declare (ignore x)) |
---|
| 110 | (format t "read-error, dropping ~A.~%" async-fd) |
---|
| 111 | (setf (gethash (async-fd-read-fd async-fd) client-hash) nil) |
---|
| 112 | (remove-async-fd event-queue async-fd :read) |
---|
| 113 | (remove-async-fd event-queue async-fd :write) |
---|
| 114 | (force-close-async-fd async-fd) |
---|
| 115 | (throw 'error-exit nil)))) |
---|
| 116 | |
---|
[10] | 117 | (when (read-event-p event) (read-more async-fd)) |
---|
| 118 | (when (write-event-p event) (write-more async-fd))))) |
---|
[1] | 119 | )) |
---|
[10] | 120 | ))))) |
---|
[1] | 121 | (ignore-errors |
---|
| 122 | (close-fd sock)))) |
---|