Refactor to make cooperative hacking nicer

1 files changed, 160 insertions, 0 deletions

diff --git a/src/player.lisp b/src/player.lisp
new file mode 100644
index 0000000..db78e57
--- /dev/null
+++ b/src/player.lisp
@@ -0,0 +1,160 @@
+;;;; player.lisp
+
+(in-package :dnd)
+
+;;; MODEL CLASSES 
+
+(defclass player (db:store-object has-uid)
+  ((nick
+    :reader nickname
+    :initarg :nickname
+    :initform (error "Players must have a nick")
+    :type string
+    :index-type idx:string-unique-index
+    :index-reader player-with-nick)
+   (pwhash
+    :accessor pwhash
+    :type string
+    :initarg :pwhash
+    :documentation "A hash of the password, hashed with the value of the pwsalt slot.")
+   (pwsalt
+    :reader pwsalt
+    :initform (nuid)
+    :type string
+    :documentation "Salt for this hero's password hash."))
+  (:metaclass db:persistent-class))
+
+(defclass session (db:store-object)
+  ((player :reader session-player
+         :initarg :player)
+   (id :reader session-id
+       :initform (nuid)
+       :index-type idx:string-unique-index
+       :index-reader session-with-id))
+  (:metaclass db:persistent-class))
+
+;;; HELPERS
+
+;;; QUERIES
+
+(defun all-players ()
+  (db:store-objects-with-class 'player))
+
+(defun all-other-players (player)
+  (remove-if (lambda (p) (eq player p)) (all-players)))
+
+;;; TRANSACTIONS 
+
+(defun new-sesh (player)
+  (db:with-transaction () (make-instance 'session :player player)))
+
+(defun destroy-sesh (session)
+  (db:with-transaction () 
+    (db:delete-object session)))
+
+(defun register-player (nick)
+  (db:with-transaction ()
+    (make-instance 'player :nickname nick)))
+
+
+
+;;; MODEL VIEWS
+
+(defrender :details ((player player))
+  (with-html
+    (:div :class "player details"
+          (:h3 "Welcome " (nickname player)))))
+
+(defrender :option ((player player))
+  (with-html
+    (:option :value (uid player) (nickname player))))
+
+
+(defrender :checkbox ((player player))
+  (with-html
+    (:input :type "checkbox" :id (uid player) :name "POSSIBLE-SEER" :value (uid player))
+    (:label :for (uid player) (nickname player))))
+
+(defrender :list-item ((player player))
+  (with-html
+    (nickname player)))
+
+;;; PAGES & PAGE CLASSES
+
+(defclass/std doorkeeper ()
+  ((message)))
+
+;; the t specialization works for all render targets 
+(defrender t ((page doorkeeper))
+  (with-page (:title "Tavern Door")
+    (:h1 (message page))
+    (:form :method "POST" :action "/tavern-door"
+	   (:label :for "NICKNAME" "Wut's yer handle?:")
+	   (:input :name "NICKNAME") (:br)
+	   (:button :type "submit" "Announce Thyself"))
+    (:h2 "Eh? Ye need to register for admission?")
+    (:a :href "/join" "Follow me...")))
+
+
+(defrender t ((page (eql :join)))
+  (with-page (:title "Register Player")
+    (:header
+     (:h1 "Choose a Player Nickname"))
+    (:form :method "POST" :action "/join"
+           (:label :for "NICKNAME"
+                   "Choose a nickname using only letters, numbers, and -._ (no spaces)") (:br)
+           (:input :name "NICKNAME" :placeholder "superbob")
+           (:button :type "submit" "Register"))))
+
+
+;;; ENDPOINT HELPERS
+
+(defmacro with-session ((player &key session (redirect "/tavern-door")) &body body)
+  (let ((session (or session (gensym "SESSION"))))
+    `(a:if-let (,session (current-session))
+       (let ((,player (session-player ,session)))
+         (declare (ignorable ,player))
+       ,@body)
+       (redirect-to ,redirect))))
+
+(defun a-valid-nick (name)
+  "Errors with 400 if the name is not a valid hero name."
+  (unless (valid-nick-p name) 
+    (lzb:http-err 400 (format nil "Player Nick Invalid")))
+  name)
+
+
+;;; ENDPOINT DEFINITIONS
+
+(defendpoint* :get "/" () ()
+  (redirect-to "/tavern"))
+
+(defendpoint* :get "/tavern-door" () ()
+  "Tavern door is where the player logs into the system."
+  (let ((doorkeeper
+          (make-instance 'doorkeeper :message (or (flashed-value :tavern-door) ""))))
+    (render (page-render-mode)
+            doorkeeper)))
+
+(defendpoint* :post "/tavern-door" () ()
+  (with-plist ((nick :nickname)) (lzb:request-body)
+    (a:if-let ((player
+                (player-with-nick (string-trim " " nick))))
+      (a:when-let ((sesh
+                    (new-sesh player)))
+	(lzb:set-response-cookie
+         +session-cookie-name+ (session-id sesh)
+	 :path "/" :domain (host *config*))
+	(redirect-to "/tavern"))
+      (progn
+        (flash :tavern-door (format nil "Hrmm... ~a you say? It ain't on the register." nick))
+        (redirect-to "/tavern-door")))))
+
+(defendpoint* :get "/join" () ()
+  (render (page-render-mode) :join))
+
+(defendpoint* :post "/join" () ()
+  "Registers a new player"
+  (with-checked-plist ((nick :nickname 'a-valid-nick)) (lzb:request-body)
+    (register-player nick)
+    (redirect-to "/tavern-door")))