(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :iterate)
(require :hunchentoot)
(require :cl-who)
(require :cl-ppcre))
(defpackage :spellcaster
(:use :common-lisp :iterate :hunchentoot :cl-who)
(:export :start :stop))
(in-package :spellcaster)
(defparameter *default-users* '(("Emó" nil) ("Peti" nil)))
(defparameter *default-port* 2001)
(defparameter *css*
"<!-- ... ")
(defparameter *spells*
" Spells in Forward Order ... ")
(defparameter *rules*
" Waving Hands from /Duel Purpose/ ... ")
(defvar *spellcaster-server*)
(defvar *users*)
(defvar *chat*)
(defvar *notes*)
(defvar *hidden-count*)
(defun login-user (user)
(start-session)
(setf (session-value 'user) user)
(with-html-output-to-string
(*standard-output* nil :prologue t :indent t)
(:html (:head (:meta :http-equiv "Refresh" :content "0; URL=/cast"))
(:body "Logging in... if nothing happens, click "
(:a :href "/cast" "here.")))))
(defun display-login (&key with-warning)
(with-html-output-to-string
(*standard-output* nil :prologue t :indent t)
(:html
(:head (:title "Spellcaster Server - Login"))
(:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8")
(:body
(:h1 "Spellcaster Login")
(when with-warning (htm (:b "Invalid password.")))
(:form :method "post"
(:table
(:tr (:td "User:")
(:td (:select :name "user"
(iter (for (user pass) in *users*)
(for i upfrom 0)
(htm (:option :value i
(str user)))))))
(:tr (:td "Password:")
(:td (:input :type "password" :name "password"))))
(:input :type "submit" :value "Login"))))))
(defun unpack-post-parameter (parameter)
(cdr (assoc parameter (post-parameters) :test #'string=)))
(declaim (inline unpack-post-parameter))
(defun login-page ()
(when (session-value 'user)
(remove-session *session*))
(let ((user-str (unpack-post-parameter "user"))
(pass (unpack-post-parameter "password")))
(if (and user-str pass)
(let ((user (parse-integer user-str)))
(cond ((null (second (elt *users* user)))
(setf (second (elt *users* user)) pass)
(login-user user))
((string= (second (elt *users* user)) pass)
(login-user user))
(t (display-login :with-warning t))))
(display-login))))
(defun access-denied ()
(with-html-output-to-string (*standard-output* nil :prologue t :indent t)
(:html
(:head (:title "Spellcaster Server"))
(:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8")
(:body
(:h1 "Access denied")
(:p "Please log in " (:a :href "/" "here."))))))
(defun format-time (time)
(multiple-value-bind (second minute hour date month year day daylight-p zone)
(decode-universal-time time)
(declare (ignore second year day daylight-p zone))
(format nil "[~@r.~d/~2,'0d:~2,'0d]" month date hour minute)))
(defun display-chat ()
(with-html-output (*standard-output* nil :indent t)
(iter (for message in *chat*)
(htm (:span :class "time" (str (format-time (first message)))) " "
(:span :class (if (= (second message) 0) "player1" "player2")
(fmt "~a: " (first (elt *users* (second message)))))
(iter (for (contents type) in (third message))
(case type
(normal (str contents))
(shown (htm (:span :class "shown" (str contents))))
(t (if (= (second message) (session-value 'user))
(htm (:span :class "hidden" (str contents)))
(htm (:form :class "hide-form" :method "post"
(:input :type "submit"
:name type
:value "Show")))))))
(:br)))))
(defun display-main-page (&optional time)
(with-html-output-to-string (*standard-output* nil :prologue t :indent t)
(:html
(:head (:title "Spellcaster Server"))
(:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8")
(:style :type "text/css" (str *css*))
(:body
(:h1 "Spellcaster")
(:form :method "post"
(:input :type "text" :name "message" :size 80 :autocomplete "off")
(:input :type "submit" :value "Send"))
(:div :class "chat" (display-chat))
(:hr)
(:form :method "post"
(:textarea :name "notes" :rows 10 :cols 70
(str (elt *notes* (session-value 'user))))
(:br) (:input :type "submit" :value "Save notes / Refresh")
(when time (fmt " Saved ~a" (format-time time))))
(:hr) (:pre (str *spells*))
(:hr) (:pre (str *rules*))))))
(defun parse-message (message)
(let ((start (position #\{ message)))
(if start
(let ((end (position #\} message :start start)))
(if end
(cons (list (subseq message 0 start) 'normal)
(cons (list (subseq message (1+ start) end)
(format nil "hidden~d" (incf *hidden-count*)))
(parse-message (subseq message (1+ end)))))
(list (list message 'normal))))
(list (list message 'normal)))))
(defun create-message (message)
(list (get-universal-time)
(session-value 'user)
(parse-message message)))
(defun look-for-hidden-parameter ()
(iter (for (key . value) in (post-parameters))
(when (cl-ppcre:scan "^hidden[0-9]+$" key)
(leave key))))
(defun show-hidden-message (key)
(iter (for message in *chat*)
(iter (for part in (third message))
(when (and (stringp (second part))
(string= (second part) key))
(setf (second part) 'shown)
(return-from show-hidden-message)))))
(defun cast-page ()
(let ((message (unpack-post-parameter "message"))
(notes (unpack-post-parameter "notes"))
(hidden (look-for-hidden-parameter)))
(cond ((null (session-value 'user)) (access-denied))
(notes (setf (elt *notes* (session-value 'user)) notes)
(display-main-page (get-universal-time)))
(message (push (create-message message) *chat*)
(display-main-page))
(hidden (show-hidden-message hidden) (display-main-page))
(t (display-main-page)))))
(defun generate-notes ()
(labels ((spaces (k)
(iter (repeat k) (collect #\Space)))
(center-string (str n)
(let ((k (length str)))
(format nil "~{~a~}~a~{~a~}"
(spaces (ceiling (- n k) 2))
str
(spaces (floor (- n k) 2))))))
(format nil " ~a ~a Comments
Health: IIIIIIIIIIIIIII IIIIIIIIIIIIIII
---------------------------------------------------------------------
Round 01 ~a ~a~%"
(center-string (first (first *users*)) 15)
(center-string (first (second *users*)) 15)
(center-string "? ?" 15)
(center-string "? ?" 15))))
(defun start (&key (port *default-port*) users)
(setf *spellcaster-server* (start-server :port port)
*users* (or (and users (mapcar (lambda (u) (list u ())) users))
(copy-tree *default-users*))
*chat* ()
*notes* (list (generate-notes) (generate-notes))
*hidden-count* 0)
(setf *dispatch-table*
(list (create-regex-dispatcher "^/$" #'login-page)
(create-regex-dispatcher "^/cast$" #'cast-page))))
(defun stop ()
(reset-sessions)
(stop-server *spellcaster-server*))