X-Git-Url: http://git.pond.sub.org/?p=eow;a=blobdiff_plain;f=empire.lisp;h=f4fb8b2a7619525dd1337fd97ce5c662251d3fa7;hp=358d0010f5d8c5c1d1d715a60ebf89afd2c46ecb;hb=54e14006564ff34c8249b9ddb357201759d77101;hpb=761774603f988ef58b11ab22c5bbf862819f9cef diff --git a/empire.lisp b/empire.lisp index 358d001..f4fb8b2 100644 --- a/empire.lisp +++ b/empire.lisp @@ -9,6 +9,8 @@ (defvar *default-empire-server* "localhost") (defvar *default-empire-server-port* 6665) +(defvar *last-active-connection* nil) + (defclass connection () ((user :initarg :user @@ -44,7 +46,12 @@ (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") + (xdump :accessor xdump :initform (xdump:make-parser)))) (defun make-connection (&key (user nil) (password nil) @@ -81,25 +88,28 @@ (handler (spawn-with-name (format nil "empire-handler-~a" user) #'handle-connection connection))) (setf (connection-handler connection) handler) - (empire-log:info "empire:connect: ~a" connection) + (empire-log:info "~a: connect" connection) connection)) (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)) - (s (usocket:socket-stream sock)) - (handler (spawn-with-name (format nil "empire-handler-~a" user) - #'handle-connection c))) + (s (usocket:socket-stream sock))) (setf socket sock stream s - connection-handler handler))) - (empire-log:info "empire:reconnect: ~a" c)) + connection-handler (spawn-with-name (format nil "empire-handler-~a" user) + #'handle-connection c)))) + (empire-log:info "~a: reconnect" c)) (defparameter +C_CMDOK+ "0") (defparameter +C_DATA+ "1") @@ -120,8 +130,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) @@ -131,27 +141,51 @@ (defmethod set-new-mode ((m base-mode) new-mode) (let* ((c (connection m)) (mode (make-mode c new-mode))) + (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)) (defgeneric handle-prompt (base-mode message)) (defgeneric handle-flush (base-mode message)) (defgeneric handle-simple-message (base-mode message)) +(defgeneric handle-ignore (base-mode message)) (defmethod handle-init ((m init-mode) message) (declare (ignorable message)) - (with-slots (play-sent-p) m - (if (not play-sent-p) - (progn - (play (connection m)) - (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)) - (quit (connection m))) + (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) (defmethod handle-exit ((m play-mode) message) (declare (ignorable message)) @@ -167,15 +201,34 @@ (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)) + t) (defparameter *line-type-dispatch* (list `(,+C_DATA+ . handle-data) @@ -184,6 +237,7 @@ `(,+C_FLUSH+ . handle-flush) `(,+C_BADCMD+ . handle-simple-message) `(,+C_FLASH+ . handle-simple-message) + `(,+C_CMDOK+ . handle-cmdok) `(,+C_PROMPT+ . handle-prompt))) (defun parse-server-line (line) @@ -215,7 +269,8 @@ (handler-case (let* ((s (network-stream c)) (line (read-line s))) - (empire-log:info "< ~a~%" line) + (empire-log:info "~a: < ~a" c line) + (setf *last-active-connection* c) (multiple-value-bind (message type) (parse-server-line line) (let ((handler (lookup-handler type)) (mode (connection-mode c))) @@ -224,41 +279,95 @@ (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) (write-sequence message s) (terpri s) (force-output s)) - -(defmethod send-message ((c connection) message) + +(defgeneric send-message-one (connection string)) +(defmethod send-message-one ((c connection) message) + (empire-log:info "~a: > ~a" c message) + (setf *last-active-connection* c) (let ((s (network-stream c))) - (empire-log:info "> ~a~%" message) - (let ((sent-p nil) - (tries 3)) - (loop - while (and (not sent-p) - (> tries 0)) - do (handler-case - (progn - (raw-send-message s message) - (setf sent-p t)) - (sb-int:closed-stream-error () - (progn - (decf tries) - (empire-log:info "Connection close - retrying (~a tries left)" tries) - (reconnect c)))))) - message)) - -(defgeneric play (connection)) -(defmethod play ((c connection)) - (with-slots (user password) c - (send-message c (format nil "play FIXME ~a ~a" user password)))) + (raw-send-message s message))) -(defmethod quit ((c connection)) - (usocket:socket-close (socket c))) +(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) + (and (> (length line) 0) + (char= +special-command-char+ (aref line 0)))) + +(defclass xdump-mode (play-mode) + ((phase :initform :meta-meta) + (dump-queue :initform nil) + (dump-index :initform 0))) +(defmethod handle-data ((m xdump-mode) message) + (with-slots (connection phase dump-queue dump-index) m + (xdump:with-parser (xdump connection) + (if (xdump:parse-line (xdump connection) message) + ;;XXX consider something like a 'pop-mode function + (ccase phase + (:meta-meta + (setf phase :meta-table) + (send-message connection "xdump meta table")) + (:meta-table + (setf phase :table-table) + (send-message connection "xdump table *")) + (:table-table + (setf phase :meta-type) + (send-message connection "xdump meta meta-type")) + (:meta-type + (setf phase :type-table) + (send-message connection "xdump meta-type *")) + (:type-table + (setf phase :tables-meta + dump-queue (xdump::table-entries (xdump:table "table")) + dump-index 0) + (send-message connection (format nil "xdump meta ~a" (xdump-data:name (aref dump-queue 0))))) + (:tables-meta + (setf phase :tables-content) + (send-message connection (format nil "xdump ~a *" (xdump-data:name (aref dump-queue dump-index))))) + (:tables-content + (if (< dump-index (fill-pointer dump-queue)) + (progn (setf phase :tables-meta) + (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: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:name (aref dump-queue dump-index)))))) + (progn + (xdump:checkpoint) + (set-new-mode (connection-mode connection) 'play-mode))))))))) -;;; Tests -(defvar *l1* "2 Empire server ready") -;; (parse-server-line *l1*) +(defmethod special-xup ((c connection)) + (let ((user-log (empire-log:open-user-log (user c)))) + (setf (xdump c) (xdump:make-parser :user-log user-log)) + (send-message c "xdump meta meta" :next-mode 'xdump-mode))) + +(defmethod special-command ((c connection) line) + (cond ((string= line "xup") (special-xup c)) + (t (empire-web:data (session c) "Unknown special command"))) + line) + +(defmethod command ((c connection) line) + (cond ((special-command-p line) (special-command c (subseq line 1))) + (t (send-message c line)))) + +(defmethod quit ((c connection)) + (usocket:socket-close (socket c)))