From cc3f850c514967ae2f9effef7e68e1d4965c6865 Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 1 Apr 2023 09:48:08 -0700 Subject: Refactor to make cooperative hacking nicer --- src/endpoints.lisp | 227 ----------------------------------------------------- 1 file changed, 227 deletions(-) delete mode 100644 src/endpoints.lisp (limited to 'src/endpoints.lisp') 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)))) - - - -- cgit v1.2.3