io.event/server-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 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :io.event)
  25
  26 ;;;; Server
  27
  28 (defclass event-manager ()
  29   ()
  30   (:documentation ""))
  31
  32 (defclass protocol-manager-mixin ()
  33   ((protocol :initarg :protocol :accessor protocol-of))
  34   (:documentation ""))
  35
  36 #- (and)
  37 (defmethod initialize-instance :after ((pmm protocol-manager-mixin) &key)
  38   (with-slots (protocol) pmm
  39     (unless (typep protocol 'io-protocol)
  40       (setq protocol (make-instance protocol)))))
  41
  42 (defclass server (event-manager protocol-manager-mixin)
  43   ()
  44   (:documentation ""))
  45
  46 (defclass tcp-server (server)
  47   ((connections :initform nil :accessor connections-of))
  48   (:documentation ""))
  49
  50 (defmethod print-object ((tcp-server server) stream)
  51   (print-unreadable-object (tcp-server stream :type t :identity t)
  52     (format stream "~A connection" (length (connections-of tcp-server)))))
  53
  54 ;;; wtf?
  55 #- (and)
  56 (defgeneric on-connection-received (factory event-base socket))
  57
  58 #- (and)
  59 (defmethod on-connection-received ((factory server-factory)
  60                                    (event-loop event-base)
  61                                    (socket active-socket))
  62   )
  63
  64 (defclass client (event-manager protocol-manager-mixin)
  65   ()
  66   (:documentation ""))
  67
  68 ;;;; Event Loop
  69
  70 (defclass event-loop (event-base)
  71   ((sockets :initform (make-hash-table :test #'eql)
  72             :accessor sockets-of)
  73    (protocols :initform (make-hash-table :test #'eql)
  74               :accessor protocols-of)))
  75
  76 (defun listen-tcp (event-loop &key host port server)
  77   (check-type event-loop event-loop)
  78   (check-type port (unsigned-byte 16))
  79   (check-type server tcp-server)
  80   (let* ((host (ensure-address host))
  81          (socket (make-socket :family (address-type host)
  82                               :type :stream :connect :passive
  83                               :local-host host :local-port port)))
  84     (setf (fd-non-blocking socket) t)
  85     (setf (gethash (fd-of socket) (sockets-of event-loop)) socket)
  86     (add-fd event-loop (fd-of socket) :read
  87             (lambda (fd event)
  88               (declare (ignore fd))
  89               (ecase event
  90                 (:read
  91                  (let ((peer (accept-connection socket)))
  92                    (when peer
  93                      ;; The transport sets things up.
  94                      (let* ((transport (change-class peer 'tcp-transport
  95                                                      :event-loop event-loop))
  96                             (protocol (make-instance (protocol-of server)
  97                                                      :transport transport)))
  98                        ;; how tricky (or how bad an idea) would it be
  99                        ;; to have the transport, socket and
 100                        ;; protocol/connection all be the same object?
 101                        (setf (protocol-of transport) protocol)
 102                        ;; why save protocols in the event-loop?
 103                        ;; (setf (gethash (fd-of peer) (protocols-of event-loop))
 104                        ;;       (cons peer protocol))
 105                        (push protocol (connections-of server))
 106                        #- (and)
 107                        (add-fd event-loop (fd-of peer) :read
 108                                (lambda (fd event)
 109                                  (declare (ignore fd))
 110                                  (ecase event
 111                                    (:read
 112                                     (on-data-received protocol
 113                                                       #(104 101 108 108 111 33 13 10)))
 114                                    (:error
 115                                     (warn "connection error")))))
 116                        ))))
 117                 (:error
 118                  (error "Got an error on the server socket: ~A~%" socket)))))))
 119
 120 (defvar *default-event-loop* (make-instance 'event-loop))
 121
 122 ;;; quick hack
 123 (defun run-tcp-server (server &rest listen-tcp-args)
 124   (apply #'listen-tcp *default-event-loop*
 125          :server (make-instance server)
 126          listen-tcp-args)
 127   (event-dispatch *default-event-loop*))