introduce session objects
[eow] / web.lisp
1 (in-package :empire-web)
2
3 (declaim (optimize (space 0) (speed 0) (safety 3) (debug 3)))
4
5
6 (defvar *this-file* (load-time-value
7                      (or #.*compile-file-pathname* *load-pathname*)))
8
9 (defvar *this-dir* (make-pathname :host (pathname-host *this-file*)
10                                   :device (pathname-device *this-file*)
11                                   :directory (pathname-directory *this-file*)))
12
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"))
20
21 (defun string-starts-with (string prefix)
22   ;; (from Hunchentoot)
23   (let ((mismatch (mismatch string prefix :test #'char=)))
24     (or (null mismatch)
25         (>= mismatch (length prefix)))))
26
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)))
33
34 (defclass session ()
35   ((update-queue
36     :accessor update-queue
37     :initform (locked-queue:create)
38     :documentation "Updates to be sent to the browser")
39    (connection
40    :accessor connection
41    :documentation "Connection to the empire game server")))
42
43 (defun make-session (username password)
44   (let* ((session (make-instance 'session))
45          (connection (empire:connect :user username
46                                      :password password
47                                      :session session)))
48     (setf (slot-value session 'connection) connection)
49     session))
50
51 (defgeneric send (session string))
52 (defgeneric prompt (session minutes btus))
53 (defgeneric data (session message))
54
55 (defun update ()
56   "Send stream of updates to client"
57   (let ((s (session-value `session)))
58     (locked-queue:dequeue (update-queue s))))
59
60 (defmethod send ((s session) string)
61   "Push a javascript update fragment to the client."
62   (locked-queue:enqueue (update-queue s) string))
63
64 (defmethod prompt ((s session) minutes btus)
65   (send s (format nil "prompt(~a,~a);~%" minutes btus)))
66
67 (defmethod data ((s session) message)
68   (send s (parenscript:ps* `(msg ,message))))
69
70 (defun login ()
71   (let ((s (session-value 'session)))
72     (if s
73         (redirect +root-url+)
74         (redirect +login-page+))))
75
76 ;; destination of login-form
77 (defun login-action ()
78   (handler-case
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))))
85
86 (defun command-action ()
87   (let ((s (session-value 'session)))
88     (empire:send-message (connection s) (get-parameter "q"))))
89
90 (defun dispatch (request)
91   (let ((script-name (script-name request)))
92     (cond
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
100
101
102 (defun start ()
103   (pushnew 'dispatch *dispatch-table* :test #'eq))
104