git.pond.sub.org Git - eow/blob - 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