1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; server-factory.lisp --- TCP server factories.
5 ;;; Copyright (C) 2007, Stelian Ionescu <sionescu@common-lisp.net>
6 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
8 ;;; This code is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the version 2.1 of
10 ;;; the GNU Lesser General Public License as published by
11 ;;; the Free Software Foundation, as clarified by the
12 ;;; preamble found here:
13 ;;; http://opensource.franz.com/preamble.html
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU Lesser General
21 ;;; Public License along with this library; if not, write to the
22 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
23 ;;; Boston, MA 02110-1301, USA
25 (in-package :io.event
)
27 ;;;; Base Factory Classes
30 ((protocol :initarg
:protocol
:accessor protocol-of
)
31 (event-base :initarg
:event-base
:accessor event-base-of
))
32 (:documentation
"Factories manage stuff."))
36 (defclass server
(factory)
40 (defclass network-server
(server)
41 ((default-local-port :initform
0 :initarg
:default-local-port
42 :accessor default-local-port-of
))
47 (defclass tcp-server
(network-server)
48 ((connections :initform nil
:accessor connections-of
))
51 (defmethod print-object ((server tcp-server
) stream
)
52 (print-unreadable-object (server stream
:type t
:identity t
)
53 (format stream
"~A connections" (length (connections-of server
)))))
55 (defgeneric on-server-connection-received
(tcp-server event-base peer
)
58 (defmethod on-server-connection-received ((server tcp-server
) (eb event-base
)
60 "Default main method for TCP-SERVERs. Instantiates a new
61 PROTOCOL and respective TRANSPORT, sets them up and pushes the
62 new PROTOCOL onto the SERVER's connection list."
63 (let* ((transport (make-instance 'tcp-transport
:event-base eb
:socket peer
))
64 (protocol (make-instance (protocol-of server
) :transport transport
)))
65 (setf (protocol-of transport
) protocol
)
66 (push protocol
(connections-of server
))))
68 ;;; Badly named, maybe.
69 (defgeneric on-server-connection-error
(tcp-server event-base
)
71 (:method
((server tcp-server
) event-base
)
72 (declare (ignore event-base
))
73 (warn "Got an error on the server socket: ~S" server
)))
75 (defgeneric listen-tcp
(server event-base
&rest socket-options
)
78 (defmethod listen-tcp ((server tcp-server
) (base event-base
)
80 (let ((socket (apply #'make-socket
82 :local-port
(getf socket-options
:local-port
83 (default-local-port-of server
))
84 :local-host
(getf socket-options
:local-host
87 (setf (fd-non-blocking socket
) t
)
88 (add-fd base
(fd-of socket
) :read
93 (let ((peer (accept-connection socket
)))
95 (on-server-connection-received server base peer
))))
97 (on-server-connection-error server base
)))))
100 ;; (defvar *default-event-base* (make-instance 'event-base))
103 (defun run-tcp-server (server &rest socket-options
)
104 (let ((event-base (make-instance 'event-base
)))
105 (apply 'listen-tcp
(make-instance server
) event-base socket-options
)
106 (event-dispatch event-base
)))
110 (defclass udp-server
(network-server)
111 ((datagram-protocol :accessor datagram-protocol-of
))
114 (defgeneric listen-udp
(server event-base
&rest socket-options
)
117 (defmethod listen-udp ((server udp-server
) (base event-base
)
118 &rest socket-options
)
119 (let ((socket (apply #'make-socket
121 :local-port
(getf socket-options
:local-port
122 (default-local-port-of server
))
123 :local-host
(getf socket-options
:local-host
126 (setf (fd-non-blocking socket
) t
)
127 (let* ((transport (make-instance
128 'udp-transport
:event-base base
:socket socket
))
129 (protocol (make-instance (protocol-of server
) :transport transport
)))
130 (setf (protocol-of transport
) protocol
131 (datagram-protocol-of server
) protocol
))
135 (defun run-udp-server (server &rest socket-options
)
136 (let ((event-base (make-instance 'event-base
)))
137 (apply 'listen-udp
(make-instance server
) event-base socket-options
)
138 (event-dispatch event-base
)))
142 (defvar *current-event-base
*)
144 ;;; KLUDGE: think this through.
145 (defun init-default-event-base (&rest options
)
146 (setq *current-event-base
*
147 (apply #'make-instance
'event-base options
)))
149 (defclass client
(factory)
153 ;;; KLUDGE: think this through.
154 (defmethod event-base-of ((client client
))
155 *current-event-base
*)
157 (defclass network-client
(client)
158 ((default-remote-port :initform
0 :initarg
:default-remote-port
159 :accessor default-remote-port-of
))
162 ;;; Could eventually share stuff with TCP-SERVER.
163 (defclass tcp-client
(network-client)
164 ((connections :initform nil
:accessor connections-of
))
167 (defgeneric add-connection
(client protocol
&rest socket-options
))
169 (defmethod add-connection ((client tcp-client
) protocol
&rest options
)
170 (let ((trans (make-instance 'tcp-transport
171 :event-base
(event-base-of client
)
172 :socket
(apply #'make-socket options
)
173 :protocol protocol
)))
174 (setf (transport-of protocol
) trans
)))
178 (defclass deferred-mixin
()
179 ((deferred :initarg
:deferred
:accessor deferred-of
))
182 (defclass deferred
()
183 ((result-callback :accessor result-callback-of
185 (lambda (&rest values
)
186 (warn "Unhandled deferred callback: ~S" values
))
188 (error-callback :accessor error-callback-of
:initform
#'error
192 ;;; Any better syntax suggestions?
193 (defmacro with-async-handler
(return-vars form error-clauses
&body body
)
194 (with-unique-names (result-deferred)
195 `(let ((,result-deferred
,form
))
196 (setf (result-callback-of ,result-deferred
)
197 (lambda ,return-vars
,@body
))
198 (setf (error-callback-of ,result-deferred
)
205 ;;; This macro is potentially very confusing for the user. Depending
206 ;;; on whether *CURRENT-EVENT-BASE* is bound it'll either return the
207 ;;; deferred object or run an event loop and actually return the value
208 ;;; (or signal an error) instead. On that note, maybe
209 ;;; WITH-ASYNC-HANDLER should check whether it actually got a deferred
211 (defmacro with-deferred-result
(() &body body
)
212 (with-unique-names (body-fn)
213 `(flet ((,body-fn
() ,@body
))
214 (if (boundp '*current-event-base
*)
216 (call-synchronously-with-fresh-event-base #',body-fn
)))))
218 (defun call-synchronously-with-fresh-event-base (function)
219 (with-event-base (*current-event-base
* :exit-when-empty t
)
220 (let (return-values error
)
221 (with-async-handler (&rest values
) (funcall function
)
222 ((error (c) (setq error c
)))
223 (setq return-values values
))
224 (event-dispatch *current-event-base
*)
227 (apply #'values return-values
)))))