Reorganized codebase

1 files changed, 139 insertions, 0 deletions

diff --git a/src/endpoints.lisp b/src/endpoints.lisp
new file mode 100644
index 0000000..e33682b
--- /dev/null
+++ b/src/endpoints.lisp
@@ -0,0 +1,139 @@
+;;;; endpoints.lisp -- http endpoints for dnd
+
+(in-package :dnd)
+
+(lzb:provision-app ()
+ :title "Dungeons & Deadlines"
+ :version "0.1.0"
+ :content-type "text/html")
+
+(defparameter +session-cookie-name+ "dnd-session")
+
+
+;;; UTILITIES
+
+(defun redirect-to (location)
+  "Set the lazybones response header and response code for redirecting to LOCATION.
+This procedure will error if lazybones:*request* is not currently bound."
+  (setf (lzb:response-header :location) location
+	(lzb:response-code) "303"))
+
+(defun current-session ()
+  "Get the session associated with the current request. Will throw an
+error if lazybones:*request* is not currently bound. It will return
+NIL if there is no session for the current request.
+
+I.e. It should be called within the scope of a request handler."
+  (session-with-id (lzb:request-cookie +session-cookie-name+ )))
+
+(defun text-browser-p (user-agent)
+  "Returns T if user agent string matches on a list of known text browsers."
+  (some (lambda (s) (search s user-agent)) '("Emacs" "Lynx" "w3m")))
+
+(defun page-render-mode (&optional user-agent)
+  "Given the USER-AGENT string from request headers, returns a symbol which
+indicates which render mode to use. For example if Emacs is the user-agent,
+return :text-12mode."
+  (let ((user-agent
+          (or user-agent
+              (lzb:request-header :user-agent))))
+    (cond ((text-browser-p user-agent) :text-page)
+          (t :page))))
+
+(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))))
+
+(defmacro with-checked-plist (typed-keys plist &rest body)
+  "Like WITH-PLIST, but allows you to pass a checking function to
+automatically tansform plist values into something you actually
+want. This is modelled after the way LAZYBONES allows for similar
+functions in url parameters in endpoint definitions."
+  (let* ((plist-var
+           (gensym))
+         (bindings
+           (loop :for (var key . pred) :in typed-keys
+                 :when pred
+                   :collect `(,var (funcall ,(first pred) (getf ,plist-var ',key)))
+                 :else
+                   :collect `(,var (getf ,plist-var ',key)))))
+    `(let ((,plist-var ,plist))
+       (let ,bindings ,@body))))
+
+;;; VALIDATOR TRANSFORMS
+
+(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)
+
+(defun a-short-string (str)
+  (unless (and (stringp str) (< (length str) 50))
+    (lzb:http-err 400 "The value must be a string at most 50 characters long."))
+  str)
+
+
+;;; OPEN ENDPOINTS
+
+(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 "localhost")  ; TODO: generalize domain
+	(redirect-to "/tavern"))
+      (progn
+        (flash :tavern-door 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")))
+
+;;; SESSION ENDPOINTS
+
+(defendpoint* :get "/tavern" () ()
+  (with-session (me)
+    (render (page-render-mode)
+            (make-instance 'tavern :player me))))
+
+(defendpoint* :get "/godess-shrine" () ()
+  (with-session (player)
+    (render (page-render-mode) :goddess-shrine)))
+
+(defendpoint* :post "/godess-shrine" () ()
+  (with-session (player)
+    (with-checked-plist ((name :name 'a-short-string)) (lzb:request-body)
+      (birth-from-the-goddess-loins player name)
+      (redirect-to "/tavern"))))
+
+(defendpoint* :post "/new-campaign" () ()
+  (with-session (creator)
+    (with-checked-plist ((title :title 'a-short-string)) (lzb:request-body)
+      (let ((campaign
+              (create-campaign creator title)))
+        (redirect-to (urlpath campaign))))))
+