X-Git-Url: http://git.pond.sub.org/?p=eow;a=blobdiff_plain;f=empire.lisp;h=edb8316846ed5ede51dadfbd2b9eac86c7a77118;hp=14ee352df7d5b295363e310342e580b0d902199c;hb=HEAD;hpb=314f63c596d5ed625b969a92de5112069d14a8f2 diff --git a/empire.lisp b/empire.lisp index 14ee352..edb8316 100644 --- a/empire.lisp +++ b/empire.lisp @@ -44,7 +44,11 @@ (session :accessor session :initarg :session - :documentation "web session to which this connection belongs"))) + :documentation "web session to which this connection belongs") + (send-queue + :accessor send-queue + :initform (locked-queue:create) + :documentation "lines outstanding to be sent at next prompt"))) (defun make-connection (&key (user nil) (password nil) @@ -87,9 +91,13 @@ (defgeneric quit (connection)) (defgeneric handle-connection (connection)) (defgeneric read-message (connection)) -(defgeneric send-message (connection message)) +(defgeneric send-message (connection message &key next-mode)) +(defgeneric connected-p (connection)) (defgeneric reconnect (conncetion)) +(defmethod connected-p ((c connection)) + (sb-thread:thread-alive-p (connection-handler c))) + (defmethod reconnect ((c connection)) (with-slots (server-name server-port user password socket stream connection-handler) c (let* ((sock (usocket:socket-connect server-name server-port)) @@ -119,8 +127,8 @@ (defclass base-mode () ((connection :initarg :connection :accessor connection))) (defclass init-mode (base-mode) - ((play-sent-p :initform nil - :documentation "Have we already sent the play command?"))) + ((phase :initform :initial + :documentation "Initialization phase"))) (defclass play-mode (base-mode) nil) (defun make-mode (connection mode) @@ -133,6 +141,7 @@ (empire-log:info "~a: set-new-mode ~a -> ~a" c (connection-mode c) new-mode) (setf (connection-mode c) mode))) +(defgeneric handle-cmdok (base-mode message)) (defgeneric handle-data (base-mode message)) (defgeneric handle-init (base-mode message)) (defgeneric handle-exit (base-mode message)) @@ -143,14 +152,35 @@ (defmethod handle-init ((m init-mode) message) (declare (ignorable message)) - (with-slots (play-sent-p) m - (if (not play-sent-p) - (let ((c (connection m))) - (login-and-play c) - (setf play-sent-p t)) - (set-new-mode m 'play-mode)))) + (with-slots (phase connection) m + (ecase phase + (:initial (handle-cmdok m message)) + (:play-sent (set-new-mode m 'play-mode))))) + +(defmethod handle-cmdok ((m init-mode) message) + (declare (ignorable message)) + (with-slots (phase connection) m + (flet ((init-phase (mode send-args next-phase) + (with-slots (phase connection) mode + (send-message-one connection (apply #'format nil send-args)) + (setf phase next-phase)))) + (with-slots (user password) (connection m) + (ecase phase + (:initial (init-phase m `("client eow ~a" ,*version*) :client-sent)) + (:client-sent (init-phase m `("coun ~a" ,user) :coun-sent)) + (:coun-sent (init-phase m `("pass ~a" ,password) :pass-sent)) + (:pass-sent (init-phase m '("play") :play-sent))))))) (defmethod handle-exit ((m init-mode) message) + (declare (ignorable message)) + (with-slots (phase connection) m + (ecase phase + (:play-sent (send-message-one connection "kill") + (setf phase :kill-sent)) + (:kill-sent (send-message-one connection "play") + (setf phase :play-sent))))) + +(defmethod handle-data ((m init-mode) message) (declare (ignorable message)) t) @@ -168,15 +198,30 @@ (defmethod handle-flush ((m play-mode) message) (let* ((c (connection m))) - (empire-web:prompt (session c) message))) + (empire-web:prompt (session c) message) + (send-next-line c))) + +(defmethod send-next-line ((c connection)) + (let ((next-event (locked-queue:dequeue (send-queue c)))) + (etypecase next-event + (string (send-message-one c next-event)) + (cons (let ((message (car next-event)) + (mode (cdr next-event))) + (send-message-one c message) + (set-new-mode (connection-mode c) mode)))))) + +(defun read-no-eval (stream) + (let ((*read-eval* nil)) + (read stream))) (defmethod handle-prompt ((m play-mode) message) (let* ((c (connection m))) (with-input-from-string (s message) - (let* ((minutes (read s)) ;;FIXME DANGEROUS - (btus (read s))) + (let* ((minutes (read-no-eval s)) + (btus (read-no-eval s))) (empire-web:prompt (session c) - (format nil "[~a,~a]: " minutes btus)))))) + (format nil "[~a,~a]: " minutes btus)))) + (send-next-line c))) (defmethod handle-ignore ((m init-mode) message) (declare (ignorable message)) @@ -189,7 +234,7 @@ `(,+C_FLUSH+ . handle-flush) `(,+C_BADCMD+ . handle-simple-message) `(,+C_FLASH+ . handle-simple-message) - `(,+C_CMDOK+ . handle-ignore) + `(,+C_CMDOK+ . handle-cmdok) `(,+C_PROMPT+ . handle-prompt))) (defun parse-server-line (line) @@ -230,6 +275,7 @@ (error 'no-handler :mode mode :type type)))) line) (sb-int:closed-stream-error () nil) + (sb-int:simple-stream-error () nil) (end-of-file () nil))) (defun raw-send-message (s message) @@ -243,30 +289,65 @@ (let ((s (network-stream c))) (raw-send-message s message))) -(defmethod send-message ((c connection) message) - (let ((sent-p nil) - (tries 3)) - (loop - while (and (not sent-p) - (> tries 0)) - do (handler-case - (progn - (send-message-one c message) - (setf sent-p t)) - (sb-int:closed-stream-error () - (progn - (decf tries) - (empire-log:info "~a: Connection close - retrying (~a tries left)" c tries) - (reconnect c)))))) - message) +(defmethod send-message ((c connection) message &key next-mode) + (if (not (connected-p c)) + (reconnect c)) + (if next-mode + (locked-queue:enqueue (send-queue c) (cons message next-mode)) + (locked-queue:enqueue (send-queue c) message))) (defparameter +special-command-char+ #\;) (defun special-command-p (line) - (char= +special-command-char+ (aref line 0))) + (and (> (length line) 0) + (char= +special-command-char+ (aref line 0)))) + +(defclass xdump-mode (play-mode) + ((parser :initform (xdump:make-parser)) + (phase :initform :meta-meta) + (dump-queue :initform nil) + (dump-index :initform 0))) + +(defmethod handle-data ((m xdump-mode) message) + (with-slots (connection parser phase dump-queue dump-index) m + (if (xdump:parse-line parser message) + ;;XXX consider something like a 'pop-mode function + (ccase phase + (:meta-meta + (setf phase :meta-table + parser (xdump:make-parser)) + (send-message connection "xdump meta table")) + (:meta-table + (setf phase :table-table + parser (xdump:make-parser)) + (send-message connection "xdump table *")) + (:table-table + (setf phase :tables-meta + dump-queue (xdump::table-entries (xdump::get-table "table")) + dump-index 0 + parser (xdump:make-parser)) + (send-message connection (format nil "xdump meta ~a" (xdump-data::table-name (aref dump-queue 0))))) + (:tables-meta + (setf phase :tables-content + parser (xdump:make-parser)) + (send-message connection (format nil "xdump ~a *" (xdump-data::table-name (aref dump-queue dump-index))))) + (:tables-content + (if (< dump-index (fill-pointer dump-queue)) + (progn (setf phase :tables-meta + parser (xdump:make-parser)) + (incf dump-index) + (loop while (and (< dump-index (fill-pointer dump-queue)) + (let ((dump-queue-entry (aref dump-queue dump-index))) + (or (null dump-queue-entry) + (string= "meta" (xdump-data::table-name dump-queue-entry))))) + do (incf dump-index)) + (if (and (<= dump-index (fill-pointer dump-queue)) + (not (null (aref dump-queue dump-index)))) + (send-message connection (format nil "xdump meta ~a" (xdump-data::table-name (aref dump-queue dump-index)))))) + (set-new-mode (connection-mode connection) 'play-mode))))))) (defmethod special-xup ((c connection)) - t) + (send-message c "xdump meta meta" :next-mode 'xdump-mode)) (defmethod special-command ((c connection) line) (cond ((string= line "xup") (special-xup c)) @@ -277,20 +358,5 @@ (cond ((special-command-p line) (special-command c (subseq line 1))) (t (send-message c line)))) -(defgeneric login-and-play (connection)) -(defmethod login-and-play ((c connection)) - (send-message-one c (format nil "client eow ~a" *version*)) - (send-message-one c "user FIXME") - (with-slots (user password) c - (send-message-one c (format nil "coun ~a" user)) - (send-message-one c (format nil "pass ~a" password))) - (send-message-one c "kill") - (send-message-one c "play")) - (defmethod quit ((c connection)) (usocket:socket-close (socket c))) - - -;;; Tests -(defvar *l1* "2 Empire server ready") -;; (parse-server-line *l1*)