;;; -*- mode: lisp; syntax: common-lisp -*-

(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)

;;; Default parameters
(defparameter *default-users* '(("Emó" nil) ("Peti" nil)))
(defparameter *default-port* 2001)


;;; HTML texts... [abridged for the HTMLized version]
(defparameter *css*
  "<!-- ... ")

(defparameter *spells*
  "      Spells in Forward Order ... ")

(defparameter *rules*
  "  Waving Hands from /Duel Purpose/ ... ")


;;; Main code
(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)))))


;;; Server setup

(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*))