io.event/factory.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; server-factory.lisp --- TCP server factories.
   4 ;;;
   5 ;;; Copyright (C) 2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
   7 ;;;
   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
  14 ;;;
  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.
  19 ;;;
  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
  24
  25 (in-package :io.event)
  26
  27 ;;;; Base Factory Classes
  28
  29 (defclass factory ()
  30   ((protocol :initarg :protocol :accessor protocol-of)
  31    (event-base :initarg :event-base :accessor event-base-of))
  32   (:documentation "Factories manage stuff."))
  33
  34 ;;;; Server
  35
  36 (defclass server (factory)
  37   ()
  38   (:documentation ""))
  39
  40 (defclass network-server (server)
  41   ((default-local-port :initform 0 :initarg :default-local-port
  42                        :accessor default-local-port-of))
  43   (:documentation ""))
  44
  45 ;;;; TCP Server
  46
  47 (defclass tcp-server (network-server)
  48   ((connections :initform nil :accessor connections-of))
  49   (:documentation ""))
  50
  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)))))
  54
  55 (defgeneric on-server-connection-received (tcp-server event-base peer)
  56   (:documentation ""))
  57
  58 (defmethod on-server-connection-received ((server tcp-server) (eb event-base)
  59                                           peer)
  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))))
  67
  68 ;;; Badly named, maybe.
  69 (defgeneric on-server-connection-error (tcp-server event-base)
  70   (:documentation "")
  71   (:method ((server tcp-server) event-base)
  72     (declare (ignore event-base))
  73     (warn "Got an error on the server socket: ~S" server)))
  74
  75 (defgeneric listen-tcp (server event-base &rest socket-options)
  76   (:documentation ""))
  77
  78 (defmethod listen-tcp ((server tcp-server) (base event-base)
  79                        &rest socket-options)
  80   (let ((socket (apply #'make-socket
  81                        :connect :passive
  82                        :local-port (getf socket-options :local-port
  83                                          (default-local-port-of server))
  84                        :local-host (getf socket-options :local-host
  85                                          +ipv4-unspecified+)
  86                        socket-options)))
  87     (setf (fd-non-blocking socket) t)
  88     (add-fd base (fd-of socket) :read
  89             (lambda (fd event)
  90               (declare (ignore fd))
  91               (ecase event
  92                 (:read
  93                  (let ((peer (accept-connection socket)))
  94                    (when peer
  95                      (on-server-connection-received server base peer))))
  96                 (:error
  97                  (on-server-connection-error server base)))))
  98     socket))
  99
 100 ;; (defvar *default-event-base* (make-instance 'event-base))
 101
 102 ;;; testing
 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)))
 107
 108 ;;;; UDP Server
 109
 110 (defclass udp-server (network-server)
 111   ((datagram-protocol :accessor datagram-protocol-of))
 112   (:documentation ""))
 113
 114 (defgeneric listen-udp (server event-base &rest socket-options)
 115   (:documentation ""))
 116
 117 (defmethod listen-udp ((server udp-server) (base event-base)
 118                        &rest socket-options)
 119   (let ((socket (apply #'make-socket
 120                        :type :datagram
 121                        :local-port (getf socket-options :local-port
 122                                          (default-local-port-of server))
 123                        :local-host (getf socket-options :local-host
 124                                          +ipv4-unspecified+)
 125                        socket-options)))
 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))
 132     socket))
 133
 134 ;;; testing
 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)))
 139
 140 ;;;; Client
 141
 142 (defvar *current-event-base*)
 143
 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)))
 148
 149 (defclass client (factory)
 150   ()
 151   (:documentation ""))
 152
 153 ;;; KLUDGE: think this through.
 154 (defmethod event-base-of ((client client))
 155   *current-event-base*)
 156
 157 (defclass network-client (client)
 158   ((default-remote-port :initform 0 :initarg :default-remote-port
 159                         :accessor default-remote-port-of))
 160   (:documentation ""))
 161
 162 ;;; Could eventually share stuff with TCP-SERVER.
 163 (defclass tcp-client (network-client)
 164   ((connections :initform nil :accessor connections-of))
 165   (:documentation ""))
 166
 167 (defgeneric add-connection (client protocol &rest socket-options))
 168
 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)))
 175
 176 ;;;; Deferred
 177
 178 (defclass deferred-mixin ()
 179   ((deferred :initarg :deferred :accessor deferred-of))
 180   (:documentation ""))
 181
 182 (defclass deferred ()
 183   ((result-callback :accessor result-callback-of
 184                     :initform
 185                     (lambda (&rest values)
 186                       (warn "Unhandled deferred callback: ~S" values))
 187                     :documentation "")
 188    (error-callback :accessor error-callback-of :initform #'error
 189                    :documentation ""))
 190   (:documentation ""))
 191
 192 ;;; Any better syntax suggestions?
 193 (defmacro with-async-handler (return-vars form error-clauses &body body)
 194   (with-gensyms (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)
 199              (lambda (some-error)
 200                (handler-case
 201                    (error some-error)
 202                  ,@error-clauses)))
 203        ,result-deferred)))
 204
 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
 210 ;;; object.
 211 (defmacro with-deferred-result (() &body body)
 212   (with-gensyms (body-fn)
 213     `(flet ((,body-fn () ,@body))
 214        (if (boundp '*current-event-base*)
 215            (,body-fn)
 216            (call-synchronously-with-fresh-event-base #',body-fn)))))
 217
 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*)
 225       (if error
 226           (error error)
 227           (apply #'values return-values)))))