ipc.lisp

   1 ;(require 'netclos)
   2 (in-package nc)
   3 ;(use-package '(sb-simple-streams))
   4 ;;; Client
   5 ;;;
   6 (defclass meta-tcp-client (standard-class) ())
   7
   8 (defmethod validate-superclass ((class meta-tcp-client) (superclass standard-class))
   9   t)
  10
  11 ;;; Now this class can be confusing,
  12 ;;; it seems to be a character stream, however it supports
  13 ;;; multivalent read-byte and write-byte as well for HTTP convenience
  14 ;;;
  15 (defclass tcp-client-stream (sb-simple-streams:socket-simple-stream)
  16   (
  17    (remote-host :initform nil)
  18    (remote-port :initform nil)
  19 ;   (listen-sockaddr :initform nil :initarg :listen-sockaddr)
  20    (process :initform nil :accessor tcp-stream-process)
  21    (alive :initform t :accessor tcp-client-alive))
  22   (:metaclass meta-tcp-client))
  23
  24 ;; (defmethod make-instance ((class meta-tcp-client) &rest args &key host port &allow-other-keys)
  25 ;;   )
  26
  27 (defmethod tcp-client-alive ((stream t))
  28   nil)
  29
  30 (defmethod close :around ((stream tcp-client-stream) &key (abort t))
  31   ;; When remote end aborts stream while we are transfering
  32   ;; closing the stream can cause a Signal 13 on our end.
  33   (setf (tcp-client-alive stream) nil)
  34   (call-next-method))
  35
  36 (defun tcp-destroy-process (stream)
  37   (let ((process (tcp-stream-process stream)))
  38     ;; If closing multiple times
  39     (if process
  40         (acl-compat-mp:process-kill process)))
  41   (setf (tcp-stream-process stream) nil))
  42
  43
  44 ;; (setq a (make-instance 'tcp-client-stream :remote-host #(127 0 0 1) :remote-port 6600))
  45
  46
  47 ;; (setq b (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))
  48
  49 ;; (sb-bsd-sockets:socket-connect b #(127 0 0 1) 6600)
  50
  51 ;; (setq a (make-instance 'tcp-client-stream :remote-socket b :direction :io))
  52 ;; (close a)
  53
  54 ;; (read-line a)
  55
  56 ;; (progn
  57 ;;   (format a "hello~%")
  58 ;;   (force-output a))
  59
  60 ;; (tcp-client-alive a)
  61
  62
  63 ;;; Server
  64 ;;;
  65 (defclass meta-tcp-server (standard-class) ())
  66
  67 (defmethod validate-superclass ((class meta-tcp-server) (superclass standard-class))
  68   t)
  69
  70 (defclass tcp-server-stream ();socket-simple-stream)
  71   ((host :initarg :host :accessor host) ;This is the local host
  72    (port :initarg :port :accessor port)
  73 ;   (listen-socket-fd :initarg :fn-in)
  74 ;   (listen-sockaddr :initarg :listen-sockaddr)
  75    (socket :initform nil :accessor tcp-server-socket)
  76    (client-streams :initform nil)
  77    (process :initform :initializing :accessor tcp-stream-process))
  78   (:metaclass meta-tcp-server))
  79
  80 ;(defvar *tcp-server-terminate* nil)
  81
  82 ;; (defmethod make-instance :around ((class tcp-server-stream) &key host port);&rest initargs &key host port &allow-other-keys)
  83 ;;   (format t "make instance 'tcp-server-stream ~A :host ~A :port ~A~%" class host port)
  84 ;;   (setf (slot-value class 'host) host
  85 ;;      (slot-value class 'port) port)
  86 ;;   (initialize-tcp-server-process class)
  87 ;; ;  (call-next-method)
  88 ;;   class
  89 ;; )
  90
  91 ;(setq a (make-instance 'tcp-server-stream :host "localhost" :port 8223))
  92
  93 (defmethod close #|:around|# ((stream tcp-server-stream) &key (abort t))
  94   (with-slots (process) stream
  95     (setq process nil))
  96   (acl-compat-mp:process-allow-schedule)
  97   (with-slots (client-streams) stream
  98     (mapc #'(lambda (client)
  99               (close (cdr client)))
 100           client-streams)))
 101
 102 (defmethod initialize-tcp-server-process ((stream tcp-server-stream))
 103   (format t "initialize-tcp-server-process ~A~%" stream)
 104   (let ((server-name (format nil "TCP Server [~a]" (slot-value stream 'port)))
 105         proc)
 106     (setq proc (acl-compat-mp:process-run-function server-name
 107                                                    #'tcp-server-daemon-function
 108                                                    stream))
 109     (setf (tcp-stream-process stream) proc)
 110     stream))
 111
 112 ;;; Define useful errors
 113 ;;;
 114 (define-condition protocol-error (error)
 115   ((stream :initform nil :initarg :stream)))
 116
 117 (defun nslookup (hostname)
 118    "Performs a DNS look up for HOSTNAME and returns the address as a
 119    four element array, suitable for socket-connect.  If HOSTNAME is
 120    not found, a host-not-found-error condition is thrown."
 121    (if hostname
 122        (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name hostname))
 123        nil))
 124
 125 (defmethod tcp-server-daemon-function ((stream tcp-server-stream))
 126   (handler-case
 127       (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))
 128             (host (host stream))
 129             (port (port stream))
 130             (client nil))
 131         (setf (tcp-server-socket stream) socket)
 132         (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
 133         (setf (sb-bsd-sockets:non-blocking-mode socket) t)
 134         (format t "bind~%")
 135         (sb-bsd-sockets:socket-bind socket (nslookup host) port)
 136         (format t "listen~%") (force-output)
 137         (sb-bsd-sockets:socket-listen socket 5)
 138 ;       (loop until *tcp-server-terminate* do
 139         (unwind-protect
 140              (block nil
 141                (handler-case
 142                    (loop
 143                       (cond ((tcp-stream-process stream)
 144                              (setq client (sb-bsd-sockets:socket-accept socket))
 145 ;                            (format t "accepted ~A~%" client)
 146 ;                            (force-output)
 147                              (cond ((null client)
 148                                     (sleep 0.1))
 149
 150                                    ((< (sb-bsd-sockets:socket-file-descriptor client) 0)
 151                                     (format t "Accept failure~%")
 152                                     (force-output)
 153                                     (acl-compat-mp:without-scheduling
 154                                       (push (cons 'protocol-error nil)
 155                                             (slot-value stream 'client-streams))))
 156                                    (t
 157                                     (format t "accepted ~A~%" client)
 158                                     (force-output)
 159                                     (acl-compat-mp:without-scheduling
 160                                       (push (cons client t);(sb-bsd-sockets:socket-make-stream client :input t :output t :buffering :none))
 161                                             (slot-value stream 'client-streams))))))
 162                             (t
 163                              (return))
 164                             ))
 165                  (sb-bsd-sockets:interrupted-error ()
 166                    (sleep 0.1)))))
 167         (format t "exit") (force-output)
 168         (sb-bsd-sockets:socket-close socket))
 169
 170     (sb-bsd-sockets:address-in-use-error ()
 171       (format t "address ~A : ~A is already in use"
 172               (host stream) (port stream))
 173       (force-output)
 174       nil)))
 175
 176
 177 (defmethod stream-read ((stream tcp-server-stream))
 178   (with-slots (client-streams) stream
 179     (destructuring-bind (client . client-stream)
 180         (acl-compat-mp:without-scheduling (pop client-streams))
 181       (when client
 182         (if (symbolp client) ;Handle future protocol errors
 183             (error client :stream stream))
 184 ;;      (let ((host-address (sockaddr-in-addr listen-sockaddr))
 185 ;;            host
 186 ;;            (port (sockaddr-in-port listen-sockaddr)))
 187 ;;        (setq host (handler-case (get-host-name-by-address host-address)
 188 ;;                     (unknown-host-name () host-address)))
 189 ;;        ;; Open "" can fail here?
 190 ;(format t "tcp-client ~A~%"
 191         (make-instance 'tcp-client-stream :remote-socket client :direction :io)))))
 192 ;)
 193
 194 ;; (setq a (make-instance 'tcp-server-stream :host "localhost" :port 8223))
 195
 196 ;; (setq b (tcp-server-daemon-function a))
 197
 198 ;; (close a)
 199
 200 ;; (setq x1 (stream-read a))
 201
 202 ;; (progn
 203 ;;   (format x1 "hello, this is ~A ~A~%" (lisp-implementation-type) (lisp-implementation-version))
 204 ;;   (force-output x1))
 205
 206 ;; (read-line x1)
 207
 208 ;; (defvar *term* nil)
 209
 210 ;; (loop unless *term* do
 211 ;;      (format x1 "> ") (force-output x1)
 212 ;;      (handler-case
 213 ;;       (format x1 "~A~%" (eval (read x1)))
 214 ;;        (error (err)
 215 ;;       (format x1 "~A~%" err)))
 216 ;;      (force-output x1))
 217
 218 ;; (setq *term* t)
 219
 220 ;; (close x1)
 221 ;; ;(setq *tcp-server-terminate* t)
 222 ;; ;(sb-bsd-sockets:socket-close (tcp-server-socket a))
 223
 224
 225 ;; (sb-bsd-sockets:non-blocking-mode (tcp-server-socket a))
 226
 227 ;; (read-line d)
 228
 229 ;; (format d "hello too~%")
 230
 231 ;; (type-of d)