Refactor to make cooperative hacking nicer

1 files changed, 0 insertions, 227 deletions

diff --git a/src/endpoints.lisp b/src/endpoints.lisp
deleted file mode 100644
index a29dc3f..0000000
--- a/src/endpoints.lisp
+++ /dev/null
@@ -1,227 +0,0 @@
-;;;; 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
-
-(defmacro define-id-plucker (class)
-  (let ((function-name
-          (intern (format nil "~a-~a-WITH-ID"
-                          (if (starts-with-vowel-p (symbol-name class))
-                              "AN" "A")
-                          class)
-                  :dnd)))
-    `(defun ,function-name (id)
-       (let ((object (object-with-uid (string-upcase id))))
-         (unless (typep object ',class)
-           (lzb:http-err 404 (format nil "No ~a with id = ~a" ',class id)))
-         object))))
-
-(define-id-plucker adventure)
-
-(define-id-plucker hero)
-
-(define-id-plucker quest)
-
-(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 (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")))
-
-;;; SESSION ENDPOINTS
-
-(defendpoint* :get "/tavern" () ()
-  (with-session (me)
-    (render (page-render-mode)
-            (make-instance 'tavern :player me))))
-
-(defendpoint* :get "/tavern/adventures" () ()
-  (with-session (me)
-    (render (page-render-mode)
-            (make-instance 'tavern-adventures
-                           :your-adventures (adventures-visible-by me)))))
-
-(defendpoint* :get "/goddess-shrine" () ()
-  (with-session (player)
-    (render (page-render-mode) :goddess-shrine)))
-
-(defendpoint* :post "/goddess-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* :get "/adventure-awaits" () ()
-  (with-session (player)
-    (render (page-render-mode)
-            (make-instance 'adventure-awaits
-                           :possible-seers (remove player (all-players))))))
-
-(defendpoint* :post "/adventure-awaits" () ()
-  (with-session (creator)
-    (with-plist ((title :title) (description :description)) (lzb:request-body)
-      (let ((possible-seers
-              (loop :for (key val) :on (lzb:request-body) :by #'cddr
-                    :when (string-equal key "POSSIBLE-SEER")
-                      :collect (object-with-uid val))))
-        (redirect-to
-         (urlpath
-          (create-adventure creator title
-                            :description description
-                            :seers possible-seers)))))))
-
-
-(defendpoint* :get "/spymaster" () ()
-  (with-session (player)
-    (render (page-render-mode)
-            (make-instance 'spymaster
-                           :player player
-                           :adventures (adventures-visible-by player)))))
-
-
-(defendpoint* :post "/spymaster" () ()
-  (with-session (player)
-    (with-plist ((adventure :adventure) (reported :reported)) (lzb:request-body)
-      (let ((adventure (an-adventure-with-id adventure)))
-        (report-a-rumor player adventure reported))
-      (redirect-to "/tavern"))))
-
-;; NB for current hackers (Tue Mar  7 06:44:02 PM PST 2023)
-;; Even though these next three all look the same I'm not going to
-;; make a macro to generate them. there may be future concerns with
-;; permissions or query parameters that will make them look different.
-
-(defendpoint* :get "/adventure/:adventure an-adventure-with-id:/:title:" () ()
-  (with-session (player)
-    (render (page-render-mode)
-            (make-instance 'adventure-page
-                           :player player
-                           :adventure adventure)))) ;; for now, render raw adventure.
-
-(defendpoint* :post "/adventure/:adventure an-adventure-with-id:/:title:" () ()
-  (with-session (player)
-    (with-plist ((seer :seer)) (lzb:request-body)
-      (when (player-with-nick seer)
-	(add-adventure-seer (player-with-nick seer) adventure))
-      (redirect-to (urlpath adventure)))))
-
-
-(defendpoint* :get "/hero/:hero a-hero-with-id:/:name:" () ()
-  (with-session (player)
-    (render (page-render-mode)
-            (make-instance 'hero-page
-                           :player player
-                           :hero hero))))
-
-(defendpoint* :get "/quest/:quest a-quest-with-id:/:name:" () ()
-  (with-session (player)
-    (render (page-render-mode)
-            (make-instance 'quest-page
-                           :player player
-                           :hero quest))))
-
-
-