1 (in-package :empire-web)
3 (declaim (optimize (space 0) (speed 0) (safety 3) (debug 3)))
6 (defvar *this-file* (load-time-value
7 (or #.*compile-file-pathname* *load-pathname*)))
9 (defvar *this-dir* (make-pathname :host (pathname-host *this-file*)
10 :device (pathname-device *this-file*)
11 :directory (pathname-directory *this-file*)))
13 (defparameter +templates-root+ (namestring *this-dir*))
14 (defparameter +root-url+ "/eow/static/test.html")
15 (defparameter +web-root-base+ "/eow")
16 (defparameter +web-root+ (concatenate 'string +web-root-base+ "/"))
17 (defparameter +static-web-root+ (concatenate 'string +web-root+ "static/"))
18 (defparameter +static-files-root+ (concatenate 'string +templates-root+ "static/"))
19 (defparameter +login-page+ (concatenate 'string +static-web-root+ "login.html"))
21 (defun string-starts-with (string prefix)
23 (let ((mismatch (mismatch string prefix :test #'char=)))
25 (>= mismatch (length prefix)))))
27 (defun serve-static ()
28 "Handle a request for a file under static/ directory"
29 (let* ((script-name (script-name))
30 (fname (subseq script-name (length +static-web-root+)))
31 (fullname (concatenate 'string +static-files-root+ fname)))
32 (handle-static-file fullname)))
36 :accessor update-queue
37 :initform (locked-queue:create)
38 :documentation "Updates to be sent to the browser")
41 :documentation "Connection to the empire game server")))
43 (defun make-session (username password)
44 (let* ((session (make-instance 'session))
45 (connection (empire:connect :user username
48 (setf (slot-value session 'connection) connection)
51 (defgeneric send (session string))
52 (defgeneric prompt (session minutes btus))
53 (defgeneric data (session message))
56 "Send stream of updates to client"
57 (let ((s (session-value `session)))
58 (locked-queue:dequeue (update-queue s))))
60 (defmethod send ((s session) string)
61 "Push a javascript update fragment to the client."
62 (locked-queue:enqueue (update-queue s) string))
64 (defmethod prompt ((s session) minutes btus)
65 (send s (format nil "prompt(~a,~a);~%" minutes btus)))
67 (defmethod data ((s session) message)
68 (send s (parenscript:ps* `(msg ,message))))
71 (let ((s (session-value 'session)))
74 (redirect +login-page+))))
76 ;; destination of login-form
77 (defun login-action ()
79 (let ((session (make-session (post-parameter "username")
80 (post-parameter "password"))))
81 (setf (session-value 'session) session)
82 (redirect +root-url+))
83 (usocket:connection-refused-error (e)
84 (format nil "Connection error: ~a~%" e))))
86 (defun command-action ()
87 (let ((s (session-value 'session)))
88 (empire:send-message (connection s) (get-parameter "q"))))
90 (defun dispatch (request)
91 (let ((script-name (script-name request)))
93 ((not (string-starts-with script-name +web-root+)) nil) ; do not handle this request
94 ((string= script-name "/eow/update") 'update)
95 ((string= script-name "/eow/login") 'login-action)
96 ((string= script-name "/eow/command") 'command-action)
97 ((or (string-equal script-name +web-root-base+)
98 (string-equal script-name +web-root+)) 'login) ; go to the start page
99 ((string-starts-with script-name +static-web-root+) 'serve-static)))) ; serve static file
103 (pushnew 'dispatch *dispatch-table* :test #'eq))