io.event/transport.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; io-channel.lisp --- Transport protocol.
   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 ;;;; Transport
  28
  29 (defclass transport ()
  30   ((event-base :initarg :event-base :accessor event-base-of)
  31    (protocol :initarg :protocol :accessor protocol-of)
  32    (read-handler :accessor read-handler-of)
  33    (write-handler :accessor write-handler-of)
  34    (error-handler :accessor error-handler-of)))
  35
  36 (defgeneric on-transport-readable (transport)
  37   (:documentation ""))
  38
  39 (defgeneric on-transport-writable (transport)
  40   (:documentation ""))
  41
  42 (defgeneric on-transport-error (transport)
  43   (:documentation ""))
  44
  45 (defgeneric write-data (data transport &key &allow-other-keys)
  46   (:documentation ""))
  47
  48 (defgeneric close-transport (transport &key &allow-other-keys)
  49   (:documentation ""))
  50
  51 (defconstant +default-read-window-size+ 8192
  52   "")
  53
  54 (defclass buffered-transport (transport)
  55   ((read-buffer :accessor read-buffer-of)
  56    (read-buffered-p :initarg :read-buffered-p
  57                     :accessor read-buffered-p
  58                     :initform t)
  59    (read-window-size :initarg :read-window-size
  60                      :accessor read-window-size-of
  61                      :initform t)
  62    (write-buffer :accessor write-buffer-of)
  63    (write-buffered-p :initarg :write-buffered-p
  64                      :accessor write-buffered-p
  65                      :initform +default-read-window-size+))
  66   (:documentation ""))
  67
  68 (defmethod initialize-instance :after ((channel buffered-transport) &key
  69                                        read-buffer-size write-buffer-size)
  70   (when (read-buffered-p channel)
  71     (setf (read-buffer-of channel)
  72           (make-instance 'io-buffer :size read-buffer-size)))
  73   (when (write-buffered-p channel)
  74     (setf (write-buffer-of channel)
  75           (make-instance 'io-buffer :size write-buffer-size))))
  76
  77 ;;;; Socket Transport
  78
  79 (defclass socket-transport (transport)
  80   ((socket :initarg :socket :accessor socket-of))
  81   (:documentation ""))
  82
  83 (defmethod initialize-instance :after ((transport socket-transport) &key)
  84   (macrolet ((handler (event callback)
  85                `(add-fd (event-base-of transport) (fd-of (socket-of transport))
  86                         ,event (lambda (fd event)
  87                                  (declare (ignore fd event))
  88                                  (,callback transport)))))
  89     (setf (read-handler-of transport) (handler :read on-transport-readable)
  90           (write-handler-of transport) (handler :write on-transport-writable)
  91           (error-handler-of transport) (handler :error on-transport-error))))
  92
  93 (defmethod close-transport ((c socket-transport) &key abort)
  94   (remove-event (event-base-of c) (read-handler-of c))
  95   (remove-event (event-base-of c) (write-handler-of c))
  96   (remove-event (event-base-of c) (error-handler-of c))
  97   (close (socket-of c) :abort abort))
  98
  99 ;;;; TCP Transport
 100
 101 ;;; Unbuffered, for now.
 102 (defclass tcp-transport (#-(and) buffered-transport socket-transport)
 103   ((status :initform :unconnected :accessor status-of))
 104   (:documentation ""))
 105
 106 (defmethod on-transport-readable ((c tcp-transport))
 107   (unless (eq (status-of c) :connected)
 108     (warn "ON-TRANSPORT-READABLE on non-connected socket")
 109     (return-from on-transport-readable))
 110   (let ((buffer (make-array +default-read-window-size+
 111                             :element-type '(unsigned-byte 8)))
 112         (byte-num 0))
 113     (declare (type unsigned-byte byte-num))
 114     (handler-case
 115         (setf (values buffer byte-num) (socket-receive buffer (socket-of c)))
 116       ;; a spurious event!
 117       (nix:ewouldblock ()
 118         (warn "Got a transport-readable event but recv() returned ~
 119                EWOULDBLOCK!"))
 120       ;; FIXME: perhaps we might be a little more sophisticated here
 121       (socket-error (err)
 122         (setf (status-of c) :disconnected)
 123         (on-connection-lost (protocol-of c) c err)))
 124     (cond
 125       ;; EOF
 126       ((zerop byte-num)
 127        (setf (status-of c) :disconnected)
 128        (on-connection-end (protocol-of c) c))
 129       ;; good data
 130       ((plusp byte-num)
 131        (on-data-received (protocol-of c) c
 132                          (make-array byte-num
 133                                      :element-type (array-element-type buffer)
 134                                      :displaced-to buffer
 135                                      :displaced-index-offset 0))))))
 136
 137 (defmethod write-data (data (c tcp-transport) &key)
 138   (handler-case
 139       (let ((count (socket-send data (socket-of c))))
 140         (when (/= count (length data))
 141           ;; here it should copy what it didn't manage to send,
 142           ;; and then write it out ON-TRANSPORT-WRITABLE.
 143           (warn "WRITE-DATA didn't send everything")))
 144     (nix:ewouldblock ()
 145       (warn "WRITE-DATA EWOULDBLOCK"))))
 146
 147 ;;; FIXME: deal with full write kernel buffers
 148 (defmethod on-transport-writable ((c tcp-transport))
 149   ;; not exactly complete: infact subsequent :WRITE
 150   ;; events must be handled
 151   (cond ((eq (status-of c) :unconnected)
 152          (on-connection-made (protocol-of c) c)
 153          (setf (status-of c) :connected))
 154         (t (warn "tcp on-transport-writable: implement me"))))
 155
 156 (defmethod on-transport-error ((transport tcp-transport))
 157   ;; are we supposed to close the socket now?
 158   (on-connection-lost (protocol-of transport)
 159                       transport
 160                       (sockets::lookup-socket-error
 161                        (get-socket-option (socket-of transport) :error))))
 162
 163 ;;;; UDP Transport
 164
 165 (defclass udp-transport (socket-transport)
 166   ()
 167   (:documentation ""))
 168
 169 (defmethod on-transport-readable ((c udp-transport))
 170   (handler-case
 171       (multiple-value-bind (buffer byte-num address port)
 172           (socket-receive (make-array +default-read-window-size+
 173                                       :element-type '(unsigned-byte 8))
 174                           (socket-of c))
 175         (on-datagram-received
 176          (protocol-of c) c
 177          (make-array byte-num
 178                      :element-type (array-element-type buffer)
 179                      :displaced-to buffer
 180                      :displaced-index-offset 0)
 181          address
 182          port))
 183     ;; a spurious event!
 184     (nix:ewouldblock ()
 185       (warn "Got a transport-readable event but recv() returned ~
 186              EWOULDBLOCK!"))
 187     ;; FIXME: perhaps we might be a little more sophisticated here
 188     (socket-error (err)
 189       (warn "got error: ~S" err))))
 190
 191 ;;; we can probably just use WRITE-DATA with :REMOTE-ADDRESS and
 192 ;;; :REMOTE-PORT instead of this separate function.
 193 (defgeneric write-datagram (datagram address port transport
 194                             &key &allow-other-keys)
 195   (:documentation "")
 196   (:method (datagram address port (c udp-transport) &key)
 197     (handler-case
 198         (let ((count (socket-send datagram (socket-of c)
 199                                   :remote-address address
 200                                   :remote-port port)))
 201           (when (/= count (length datagram))
 202             ;; here it should copy what it didn't manage to send,
 203             ;; and then write it out ON-TRANSPORT-WRITABLE.
 204             (warn "WRITE-DATA didn't send everything")))
 205       (nix:ewouldblock ()
 206         (warn "WRITE-DATA EWOULDBLOCK"))
 207       (socket-error (err)
 208         (warn "write-datagram: got ~S" err)))))
 209
 210 ;;; FIXME: deal with full write kernel buffers
 211 (defmethod on-transport-writable ((c udp-transport))
 212   (warn "udp on-transport-writable: implement me"))
 213
 214 ;;; FIXME: complete it
 215 (defmethod on-transport-error ((c udp-transport))
 216   (let ((error-code (get-socket-option (socket-of c) :error)))
 217     (warn "got socket error: ~A" error-code)))