From f7abccc38ceda7024ca375d34ed88f4fb561ef02 Mon Sep 17 00:00:00 2001 From: colin Date: Sun, 5 Mar 2023 16:36:44 -0800 Subject: Reorganized codebase --- build.lisp | 16 --- dnd.asd | 35 ++++-- dnd.lisp | 17 --- endpoints.lisp | 158 --------------------------- flash.lisp | 71 ------------ init.lisp | 12 --- model.lisp | 226 -------------------------------------- package.lisp | 24 ----- pages.lisp | 173 ----------------------------- queries.lisp | 26 ----- src/build.lisp | 16 +++ src/dnd.lisp | 17 +++ src/endpoints.lisp | 139 ++++++++++++++++++++++++ src/flash.lisp | 71 ++++++++++++ src/init.lisp | 12 +++ src/model.lisp | 228 +++++++++++++++++++++++++++++++++++++++ src/names.lisp | 25 +++++ src/package.lisp | 24 +++++ src/pages.lisp | 17 +++ src/pages/doorkeeper.lisp | 19 ++++ src/pages/goddess-shrine.lisp | 13 +++ src/pages/join-gaming-group.lisp | 13 +++ src/pages/join.lisp | 13 +++ src/pages/tavern.lisp | 20 ++++ src/queries.lisp | 34 ++++++ src/render.lisp | 23 ++++ src/transactions.lisp | 22 ++++ src/utilities.lisp | 68 ++++++++++++ src/views/campaign.lisp | 8 ++ src/views/components.lisp | 33 ++++++ src/views/hazard.lisp | 4 + src/views/hero.lisp | 11 ++ src/views/player.lisp | 8 ++ src/views/quest.lisp | 4 + src/views/rumor.lisp | 4 + transactions.lisp | 22 ---- utilities.lisp | 68 ------------ 37 files changed, 871 insertions(+), 823 deletions(-) delete mode 100644 build.lisp delete mode 100644 dnd.lisp delete mode 100644 endpoints.lisp delete mode 100644 flash.lisp delete mode 100644 init.lisp delete mode 100644 model.lisp delete mode 100644 package.lisp delete mode 100644 pages.lisp delete mode 100644 queries.lisp create mode 100644 src/build.lisp create mode 100644 src/dnd.lisp create mode 100644 src/endpoints.lisp create mode 100644 src/flash.lisp create mode 100644 src/init.lisp create mode 100644 src/model.lisp create mode 100644 src/names.lisp create mode 100644 src/package.lisp create mode 100644 src/pages.lisp create mode 100644 src/pages/doorkeeper.lisp create mode 100644 src/pages/goddess-shrine.lisp create mode 100644 src/pages/join-gaming-group.lisp create mode 100644 src/pages/join.lisp create mode 100644 src/pages/tavern.lisp create mode 100644 src/queries.lisp create mode 100644 src/render.lisp create mode 100644 src/transactions.lisp create mode 100644 src/utilities.lisp create mode 100644 src/views/campaign.lisp create mode 100644 src/views/components.lisp create mode 100644 src/views/hazard.lisp create mode 100644 src/views/hero.lisp create mode 100644 src/views/player.lisp create mode 100644 src/views/quest.lisp create mode 100644 src/views/rumor.lisp delete mode 100644 transactions.lisp delete mode 100644 utilities.lisp diff --git a/build.lisp b/build.lisp deleted file mode 100644 index 8bb5ec5..0000000 --- a/build.lisp +++ /dev/null @@ -1,16 +0,0 @@ -(ql:quickload :dnd) - -(swank:swank-require - '(SWANK-IO-PACKAGE::SWANK-INDENTATION - SWANK-IO-PACKAGE::SWANK-TRACE-DIALOG - SWANK-IO-PACKAGE::SWANK-PACKAGE-FU - SWANK-IO-PACKAGE::SWANK-PRESENTATIONS - SWANK-IO-PACKAGE::SWANK-MACROSTEP - SWANK-IO-PACKAGE::SWANK-FUZZY - SWANK-IO-PACKAGE::SWANK-FANCY-INSPECTOR - SWANK-IO-PACKAGE::SWANK-C-P-C - SWANK-IO-PACKAGE::SWANK-ARGLISTS - SWANK-IO-PACKAGE::SWANK-REPL)) - -(ensure-directories-exist #P"./bin/") -(sb-ext:save-lisp-and-die "./bin/dnd" :toplevel #'dnd:boot :executable t) diff --git a/dnd.asd b/dnd.asd index 5a982d6..2720764 100644 --- a/dnd.asd +++ b/dnd.asd @@ -22,13 +22,28 @@ #:bordeaux-threads #:testiere #:defclass-std) - :components ((:file "package") - (:file "utilities") - (:file "model") - (:file "queries") - (:file "transactions") - (:file "flash") - (:file "pages") - (:file "endpoints") - (:file "init") - (:file "dnd"))) + :components ((:module "src" + :serial t + :components ((:file "package") + (:file "utilities") + (:file "model") + (:file "queries") + (:file "transactions") + (:file "flash") + (:file "names") + (:file "render") + (:module "views" + :serial t + :components ((:file "components") + (:file "hero") + (:file "player") + (:file "quest") + (:file "hazard") + (:file "campaign"))) + (:module "pages" + :serial t + :components ((:file "doorkeeper") + (:file "tavern"))) + (:FILE "endpoints") + (:file "init") + (:file "dnd"))))) diff --git a/dnd.lisp b/dnd.lisp deleted file mode 100644 index 7f7dc77..0000000 --- a/dnd.lisp +++ /dev/null @@ -1,17 +0,0 @@ -;;;; dnd.lisp - -(in-package #:dnd) - -(defvar *dnd-arena* nil - "The instance of the HTTP server") - -(defun conjure-arena () - (init-db) - (setf *dnd-arena* (lzb:create-server)) - (lzb:install-app *dnd-arena* (lzb:app 'dnd)) - (lzb:start-server *dnd-arena*)) - -(defun boot () - (swank:create-server :port 9876 :dont-close t) - (conjure-arena) - (loop (sleep 1))) diff --git a/endpoints.lisp b/endpoints.lisp deleted file mode 100644 index 96e3876..0000000 --- a/endpoints.lisp +++ /dev/null @@ -1,158 +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") - -;;; DND ROUTE PROTOCOL - -(defgeneric unique-name (object) - (:documentation "Returns a unique name for an object, or NIL if it does not have one.") - (:method ((ob t)) nil)) - -(defmethod unique-name ((campaign campaign)) - (campaign-title campaign)) - -(defmethod unique-name ((hero hero)) - (hero-name hero)) - -(defgeneric urlpath (inflection object) - (:documentation "Return the path to the object given a particular") - (:method ((inflection t) (object has-uid)) - "If the object has a unique human readable name, urlify that name and -incorporate it into the urlpath. Otherwise use the object's uid. - -Returns /inflection/class/identifier." - (format nil "~a/~a/~a" - (urlify inflection) - (urlify (class-name (class-of object))) - (urlify (or (unique-name object) (uid object)))))) - -;;; 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 (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." - (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." - (a:if-let (name (flashed-value :tavern-door)) - (doorkeeper :message (format nil "Ne'er 'erd of ye ~a" name)) - (doorkeeper))) - -(defendpoint* :post "/tavern-door" () () - (with-plist ((nick :nick)) (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 "/register" () () - (register)) - - - -(defendpoint* :post "/register" () () - "Registers a new player" - (with-checked-plist ((nick :nick '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 (lzb:request-header :user-agent)) - (make-instance 'tavern :player me)))) - -(defendpoint* :get "/godess-shrine" () () - (with-session (player) - (godess-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 :details campaign)))))) - diff --git a/flash.lisp b/flash.lisp deleted file mode 100644 index b655fa0..0000000 --- a/flash.lisp +++ /dev/null @@ -1,71 +0,0 @@ -;;;; flash.lisp -- communicating between page loads - -(in-package :dnd) - -(defvar *flashes* - (make-hash-table :test #'equal :synchronized t)) -(defvar *flash-lock* - (bt:make-lock "flash lock")) - -(defparameter +flash-cookie-name+ "DNDFLASHKEY") -(defparameter +flash-value-lifetime+ 10 - "Number of seconds a flashed value lives.") - -(defstruct flash-entry - "TABLE is a PLIST" - (timestamp (get-universal-time)) - (table nil)) - -(defun flash-entry-alive-p (entry) - "Returns T if ENTRY has not expired." - (<= (get-universal-time) - (+ (flash-entry-timestamp entry) +flash-value-lifetime+))) - -(defun flash (label value) - "A flash is a one-time inter-request value. Once stored, it can only -be retrieved once. And if not retrieved in a short period of time, it -expires." - (check-type label keyword) - (let* ((key - (or (lzb:request-cookie +flash-cookie-name+) (nuid))) - (now - (get-universal-time))) - ;; holding a lock here b/c I do stuff in between getting an entry - ;; and writing to it. - (bt:with-lock-held (*flash-lock*) - (let ((entry - (or (gethash key *flashes*) - (make-flash-entry)))) - ;; update the entry - (setf (flash-entry-timestamp entry) now - (getf (flash-entry-table entry) label) value - (gethash key *flashes*) entry))) - ;; set the cookie, updating its expiration if necessary - (lzb:set-response-cookie - +flash-cookie-name+ key - ;; TODO: generalize domain - :path "/" :domain "localhost" - :expires (+ +flash-value-lifetime+ now)))) - - -(defun flashed-value (label) - "Retrieves and deletes the flashed value with label LABEL associated -with this request. If the value exists, return it. Otherwise return -NIL." - (bt:with-lock-held (*flash-lock*) - (a:when-let* ((key (lzb:request-cookie +flash-cookie-name+)) - (entry (gethash key *flashes*))) - (cond - ((flash-entry-alive-p entry) - (let ((val (getf (flash-entry-table entry) label))) - ;; can only retrieve once - (remf (flash-entry-table entry) label) - ;; might as well delete the entry if its table is empty. - (when (null (flash-entry-table entry)) - (remhash key *flashes*)) - val)) - (t - ;; drop expired entries and return nil - (remhash key *flashes*) - nil))))) - diff --git a/init.lisp b/init.lisp deleted file mode 100644 index 68b2a16..0000000 --- a/init.lisp +++ /dev/null @@ -1,12 +0,0 @@ -;;;; init.lisp - -(in-package #:dnd) - -(defun init-db (&optional config) - (unless (boundp 'db:*store*) - (unless config - nil ; TODO: handle the case where we have a config - (make-instance - 'db:mp-store - :directory (merge-pathnames "dnd-store/" (user-homedir-pathname)) - :subsystems (list (make-instance 'db:store-object-subsystem)))))) diff --git a/model.lisp b/model.lisp deleted file mode 100644 index fef01da..0000000 --- a/model.lisp +++ /dev/null @@ -1,226 +0,0 @@ -;;;; model.lisp -- bknr.datastore class definitions for dnd - -(in-package :dnd) - -(deftype title () - `(member :noob)) - -(deftype character-class () - `(member :hero)) - -(deftype priority () - `(member :low :medium :high)) - -(defun hero-class (h) - "barGaryan") ; TODO: real implementation - -(defun hero-title (h) - "Scouse Chef") ; TODO: real implementation - -(defun renown (hero) - (experience hero)) ; TODO: real implementaiton - -;;; persistent mixins -(defclass has-uid () - ((nuid :reader uid - :initform (nuid) - :index-type idx:string-unique-index - :index-reader object-with-uid)) - (:metaclass db:persistent-class)) - -(defclass can-equip () - ((equipment-table - :initform nil - :type list - :documentation "A PLIST mapping 'equipment slots' to instances of LOOT. Equipment slots are things like :head, :torso, :left-ring, etc") - (equipment-slot-names - :initform +standard-humanoid-equipment+ - :initarg :slot-names - :type (list keyword) - :documentation "The list of slots available to this entity.")) - (:metaclass db:persistent-class)) - -(defclass has-bag () - ((bag - :reader bag - :initform nil - :type list - :documentation "A list of items that this entity is carrying.")) - (:metaclass db:persistent-class)) - -(defclass has-chronicle () - ((chronicle :accessor chronicle :initform nil)) - (:metaclass db:persistent-class) - (:documentation "A chronicle is a general purpose log of events. It stores a single slot that")) - -(defparameter +standard-humanoid-equipment+ - '(:head :neck :torso :waist :legs :feet :arms :left-fingers :right-fingers - :left-holding :right-holding :cloak) - "The equipment slots for standard humanoids") - -;; abstract class -(defclass game-object (db:store-object has-uid has-chronicle) - () - (:metaclass db:persistent-class)) - -(defclass player (db:store-object has-uid) - ((nick - :reader player-nick - :initarg :nick - :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)) - -;; a user -(defclass hero (game-object has-bag can-equip) - ((name - :accessor hero-name - :initarg :name - :initform (error "Heroes must be named") - :type string - :index-type idx:string-unique-index - :index-reader hero-known-as) - (player - :reader hero-player - :initarg :player - :type player - :index-type idx:hash-index - :index-reader player-heroes) - (campaign - :accessor hero-campaign - :initarg :campaign - :initform nil - :type campaign - :documentation "A hero may be in at most one campaign at a time.")) - (:metaclass db:persistent-class)) - - - -;; TODO expiration? -(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)) - -(defclass campaign (game-object) - ((creator - :reader campaign-creator - :initarg :creator - :initform (error "campaigns must have a creator") - :type player - :documentation "The player instance of the user who made this campaign.") - (seers - :accessor campaign-seers - :initarg :seers - :initform nil - :type (or nil (cons player)) - :documentation "Seers are the people who peer out into their instruments of divination that heroes may go on quests.") - (title - :accessor title - :initarg :title - :initform (error "A campaign needs a title") - :type string) - (rumors - :accessor campaign-rumors - :initform nil - :type (or nil (cons rumor)) - :documentation "Beasts, Monsters, and Hazards rumored to be lurking about.")) - (:metaclass db:persistent-class) - (:documentation "A campaign is a container of quests. Campaigns are expected to be engaged with on a particular schedule, and are run by particular people.")) - -(defclass rumor (db:store-object) - ((reporter - :reader rumor-reporter - :initarg :reporter - :type player - :documentation "The player who hast reported the vile rumor.") - (content - :accessor rumor-content - :initform (error "A rumor must have content") - :initarg :content - :type string - :documentation "A description of the supposed peril that awaits heroes in a particular campaign.")) - (:metaclass db:persistent-class) - (:documentation "Transcript of a rumor reported by some player related to a Campaign.")) - -(defclass quest (game-object) - ((campaign - :reader quest-campaign - :initarg :campaign - :initform (error "No quest can fall outside the scope of a campaign.") - :type campaign - :index-type idx:hash-index - :index-reader quests-in-campaign - :documentation "The campaign to which this quest belongs") - (name - :accessor quest-name - :initarg :name - :type string - :initform (format nil "~a" (gensym "QUEST"))) - (horizon-of-hope - :accessor horizon-of-hope - :initarg :deadline - :type integer - :initform nil - :documentation "When all hope becomes lost.") - (heroes - :accessor heroes-on-quest - :initarg :heroes - :initform nil - :type (or nil (cons hero)) - :documentation "A list of heroes in this quest. Join and flight dates are logged in the chronicle.") - (inception - :accessor quest-inception - :initform nil - :type (or nil integer) - :documentation "Time at which the quest began.")) - (:metaclass db:persistent-class) - (:documentation "A collection of hazards with a deadline and start date which heroes will attack.")) - -(defclass hazard (game-object) - ((quest - :accessor quest-of - :index-type idx:hash-index - :index-reader hazards-in-quest - :documentation "The quest to which this hazard belongs. Initially it is unbound. It becomes boudn when the hazard is added to a quest.") - (description - :accessor description - :initarg :description - :initform "" - :type string - :documentation "") - (overcomep - :accessor is-overcome - :initform nil - :documentation "indicates whether or not this hazard has been overcome.") - (imminence - :accessor imminence-of - :type priority - :documentation "") - (menace ;; difficulty - :accessor menace-of - :type integer - :documentation "How dangerous the hazard is." )) - (:metaclass db:persistent-class) - (:documentation "Hazard is a superclass for all hazards encountered in a quest. It's chronicle includes data about which heroes fought and which overcame.")) - -;; (defclass monster ()) - - - diff --git a/package.lisp b/package.lisp deleted file mode 100644 index 20a16d0..0000000 --- a/package.lisp +++ /dev/null @@ -1,24 +0,0 @@ -;;;; package.lisp - -(defpackage #:dnd - (:use #:cl) - (:local-nicknames (#:db #:bknr.datastore) - (#:idx #:bknr.indices) - (#:lzb #:lazybones) - (#:re #:cl-ppcre) - (#:json #:jonathan) - (#:a #:alexandria-2)) - (:import-from #:testiere - #:defun/t) - (:import-from #:lazybones - #:defendpoint*) - (:import-from #:derrida - #:with-plist) - (:import-from #:spinneret - #:with-html - #:with-html-string) - (:import-from #:defclass-std - #:defclass/std) - (:export :boot)) - - diff --git a/pages.lisp b/pages.lisp deleted file mode 100644 index 378156a..0000000 --- a/pages.lisp +++ /dev/null @@ -1,173 +0,0 @@ -;;;; pages.lisp -- html generation functions for dnd - -(in-package :dnd) - -;;; RENDER PROTOCOL - -(defgeneric render (view object &key) - (:documentation "Render OBJECT as VIEW. VIEW could be anything, but it is intended to -be a keyword for usin in EQL method specializers.")) - -(defmacro defrender (view (spec &rest kwargs) &body body) - "A helper macro for defining specializations of render." - (let ((viewvar (gensym))) - `(defmethod render ((,viewvar (eql ,view)) ,spec &key ,@kwargs) - ,@body))) - -(defrender :list ((data list) (class "listview") (item-class "listitem")) - "A catch all for rendering lists of renderable data items as unordered -lists. CLASS is the lass string for the containing list. ITEM-CLASS is -the class string for the contained list items." - (with-html - (:ol :class class - (dolist (item data) - (:li (render :list-item item :class item-class)))))) - -(defrender :three-column-layout (data) - "A catch all specialization for rendering data in three columns. You -must specialize :left :milsddle :right on your desired data type." - (with-html - (:div :class "three-column-layout" - (:div :class "left-column" (render :left data)) - (:div :class "middle-column" (render :middle data)) - (:div :class "right-column" (render :right data))))) - -;;; Object-Endpoint Helpers - -(defgeneric url-path-to (obj) - (:documentation "Return a string that is the absolute url path to OBJ.")) - -(defmethod url-path-to ((obj campaign)) - (format nil "/campaign/~a" (urlify (title obj)))) - -;;; PAGES - -(defmacro with-page ((&key title) &body body) - "A helper macro fordefining some standard page boilerplate." - `(with-html-string - (:doctype) - (:html - (:head - (:title ,title)) - (:body - ,@body)))) - -(defclass/std doorkeeper () - ((message))) - -(defun doorkeeper (&key (message "Come ye player, Wot's yer name?")) - (render :page (make-instance 'doorkeeper :message message ))) - -(defrender :page ((page doorkeeper)) - (with-page (:title "Tavern Door") - (:h1 (message page)) - (:form :method "POST" :action "/tavern-door" - (:label :for "NICK" "Wut's yer handle?:") - (:input :name "NICK") - (:button :type "submit" "Announce Thyself")) - (:h2 "Eh? Ye need to announce thyeself?") - (:a :href "/register" "Follow me..."))) - -(defclass/std goddess-shrine () ()) - -(defrender :page ((page goddess-shrine)) - (with-page (:title "A Sacred Shrine") - (:header - (:h1 "Pray and become a hero...")) - (:form :method "POST" :action "/godess-shrine" - (:label :for "NAME" "Enter the epithet by which the ages shall know thy hero:") - (:input :name "NAME") - (:button :type "submit" "Pray To The Goddess")))) - -(defclass/std player-registration () ()) - -(defrender :page ((page player-registration)) - (with-page (:title "Register Player") - (:header - (:h1 "Choose a Nickname Player")) - (:form :method "POST" :action "/register" - (:label :for "NICK" "Choose a nickname. No spaces. Letters, Numbers, and -._") - (:input :name "NICK" :placeholder "superbob") - (:button :type "submit" "Register")))) - -(defun register () - (render :page (make-instance 'player-registration))) - -(defclass/std tavern () - ((player alerts))) - -(defun tavern (player) - (render :page (make-instance 'tavern :player player))) - -(defrender :page ((tavern tavern)) - (with-page (:title "A Bustling Tavern") - (render :three-column-layout tavern))) - -(defrender :text-page ((tavern tavern)) - (let ((player (player tavern))) - (with-html - (render :details player) - (render :list (player-heroes player)) - (:a :href "/spymaster" "Report a Roguish Rumour...") - ;; (:table - ;; (:tr (:td (:h4 "Your Heroes")) - ;; (:td (:h4 "Your Campaigns"))) - ;; (:tr (:td (:h4 "Gossip & Gab")) - ;; (:td (:h4 "Comrades in Arms")))) - - ))) - -(defrender :list-item ((hero hero)) - (with-html - (with-slots ((name campaign) hero) - (:p name "the" (hero-class hero) (hero-title hero) - (when campaign - (:span "who is off in the campaign") - (:span (render :inline campaign))))))) - -(defrender :inline ((campaign campaign)) - (with-html - (:a :href (url-path-to campaign) (title campaign)))) - -(defrender :left ((tavern tavern)) - (let ((player (player tavern))) - (with-html - (render :details player) - (:h4 "Your Heroes") - (render :list (player-heroes player))))) - -(defrender :middle ((tavern tavern)) - (with-html - (:h4 "Your Campaigns ") - (render :list (player-campaigns (player tavern))))) - -(defrender :right ((tavern tavern)) - (with-html - (:h4 "Gossip & Gab") - (render :list (alerts tavern)) - (:h4 "Comrades in Arms") - (render :list (fetch-comrades (player tavern))))) - -(defrender :details ((player player)) - (with-html - (:div :class "player details" - (:h3 "Welcome " (player-nick player))))) - -(defun navbar () - (with-html - (:nav :class "navbar" :aria-label "Navigation" - (:div :class "logo" :aria-label "DND logo" "DND") - (:ul :class "nav-links" :aria-label "Nav links" - (:li (:a :href "/hero" :aria-label "Hero profile" "๐Ÿง")) - (:li (:a :href "/inventory" :aria-label "Inventory" "๐ŸŽ’")) - (:li (:a :href "/quests" :aria-label "Quests" "๐Ÿ“œ")) - (:li (:a :href "/tavern" :aria-label "Tavern" "๐Ÿบ")))))) - -(defun hall-of-heroes () - (with-html - (:ul :class "hall-of-heroes" - (dolist (hero (all-heroes)) - (:li (hero-name hero) - "the" - (hero-class hero) - (hero-title hero)))))) diff --git a/queries.lisp b/queries.lisp deleted file mode 100644 index 4538c75..0000000 --- a/queries.lisp +++ /dev/null @@ -1,26 +0,0 @@ -;;;; queries.lisp -- query the database - -(in-package :dnd) - -(defun all-heroes () - (db:store-objects-with-class 'hero)) - -(defun player-campaigns (player) - "Return a list of campaigns that that player is involved in." - (remove nil (mapcar #'hero-campaign (player-heroes player)))) - -(defun campaign-heros (campaign &key (activep t)) - "All the heros actively involved in this CAMPAIGN. If ACTIVEP, then -only the active quest(s) are considered, otherwise all quests are considered." - (remove-duplicates - (mapcan #'heroes-on-quest - (if activep - (remove-if-not #'quest-startedp (quests-in-campaign campaign)) - (quests-in-campaign campaign))))) - -(defun fetch-comrades (player &key (activep t)) - "Returns all the heroes in any one of the player's campaigns. If -ACTIVEP, then only heroes involved in active quests are returned." - (remove-duplicates - (loop :for campaign :in (player-campaigns player) - :nconc (campaign-heros campaign :activep activep)))) diff --git a/src/build.lisp b/src/build.lisp new file mode 100644 index 0000000..8bb5ec5 --- /dev/null +++ b/src/build.lisp @@ -0,0 +1,16 @@ +(ql:quickload :dnd) + +(swank:swank-require + '(SWANK-IO-PACKAGE::SWANK-INDENTATION + SWANK-IO-PACKAGE::SWANK-TRACE-DIALOG + SWANK-IO-PACKAGE::SWANK-PACKAGE-FU + SWANK-IO-PACKAGE::SWANK-PRESENTATIONS + SWANK-IO-PACKAGE::SWANK-MACROSTEP + SWANK-IO-PACKAGE::SWANK-FUZZY + SWANK-IO-PACKAGE::SWANK-FANCY-INSPECTOR + SWANK-IO-PACKAGE::SWANK-C-P-C + SWANK-IO-PACKAGE::SWANK-ARGLISTS + SWANK-IO-PACKAGE::SWANK-REPL)) + +(ensure-directories-exist #P"./bin/") +(sb-ext:save-lisp-and-die "./bin/dnd" :toplevel #'dnd:boot :executable t) diff --git a/src/dnd.lisp b/src/dnd.lisp new file mode 100644 index 0000000..ae5ae86 --- /dev/null +++ b/src/dnd.lisp @@ -0,0 +1,17 @@ +;;;; dnd.lisp + +(in-package #:dnd) + +(defvar *dnd-arena* nil + "The instance of the HTTP server") + +(defun start () + (init-db) + (setf *dnd-arena* (lzb:create-server)) + (lzb:install-app *dnd-arena* (lzb:app 'dnd)) + (lzb:start-server *dnd-arena*)) + +(defun boot () + (swank:create-server :port 9876 :dont-close t) + (conjure-arena) + (loop (sleep 1))) 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)))))) + diff --git a/src/flash.lisp b/src/flash.lisp new file mode 100644 index 0000000..b655fa0 --- /dev/null +++ b/src/flash.lisp @@ -0,0 +1,71 @@ +;;;; flash.lisp -- communicating between page loads + +(in-package :dnd) + +(defvar *flashes* + (make-hash-table :test #'equal :synchronized t)) +(defvar *flash-lock* + (bt:make-lock "flash lock")) + +(defparameter +flash-cookie-name+ "DNDFLASHKEY") +(defparameter +flash-value-lifetime+ 10 + "Number of seconds a flashed value lives.") + +(defstruct flash-entry + "TABLE is a PLIST" + (timestamp (get-universal-time)) + (table nil)) + +(defun flash-entry-alive-p (entry) + "Returns T if ENTRY has not expired." + (<= (get-universal-time) + (+ (flash-entry-timestamp entry) +flash-value-lifetime+))) + +(defun flash (label value) + "A flash is a one-time inter-request value. Once stored, it can only +be retrieved once. And if not retrieved in a short period of time, it +expires." + (check-type label keyword) + (let* ((key + (or (lzb:request-cookie +flash-cookie-name+) (nuid))) + (now + (get-universal-time))) + ;; holding a lock here b/c I do stuff in between getting an entry + ;; and writing to it. + (bt:with-lock-held (*flash-lock*) + (let ((entry + (or (gethash key *flashes*) + (make-flash-entry)))) + ;; update the entry + (setf (flash-entry-timestamp entry) now + (getf (flash-entry-table entry) label) value + (gethash key *flashes*) entry))) + ;; set the cookie, updating its expiration if necessary + (lzb:set-response-cookie + +flash-cookie-name+ key + ;; TODO: generalize domain + :path "/" :domain "localhost" + :expires (+ +flash-value-lifetime+ now)))) + + +(defun flashed-value (label) + "Retrieves and deletes the flashed value with label LABEL associated +with this request. If the value exists, return it. Otherwise return +NIL." + (bt:with-lock-held (*flash-lock*) + (a:when-let* ((key (lzb:request-cookie +flash-cookie-name+)) + (entry (gethash key *flashes*))) + (cond + ((flash-entry-alive-p entry) + (let ((val (getf (flash-entry-table entry) label))) + ;; can only retrieve once + (remf (flash-entry-table entry) label) + ;; might as well delete the entry if its table is empty. + (when (null (flash-entry-table entry)) + (remhash key *flashes*)) + val)) + (t + ;; drop expired entries and return nil + (remhash key *flashes*) + nil))))) + diff --git a/src/init.lisp b/src/init.lisp new file mode 100644 index 0000000..68b2a16 --- /dev/null +++ b/src/init.lisp @@ -0,0 +1,12 @@ +;;;; init.lisp + +(in-package #:dnd) + +(defun init-db (&optional config) + (unless (boundp 'db:*store*) + (unless config + nil ; TODO: handle the case where we have a config + (make-instance + 'db:mp-store + :directory (merge-pathnames "dnd-store/" (user-homedir-pathname)) + :subsystems (list (make-instance 'db:store-object-subsystem)))))) diff --git a/src/model.lisp b/src/model.lisp new file mode 100644 index 0000000..49cd03a --- /dev/null +++ b/src/model.lisp @@ -0,0 +1,228 @@ +;;;; model.lisp -- bknr.datastore class definitions for dnd + +(in-package :dnd) + +(deftype title () + `(member :noob)) + +(deftype character-class () + `(member :hero)) + +(deftype priority () + `(member :low :medium :high)) + +(defun hero-class (h) + "barGaryan") ; TODO: real implementation + +(defun hero-title (h) + "Scouse Chef") ; TODO: real implementation + +(defun renown (hero) + (experience hero)) ; TODO: real implementaiton + + +;;; PERSISTENT MIXINS +(defclass has-uid () + ((nuid :reader uid + :initform (nuid) + :index-type idx:string-unique-index + :index-reader object-with-uid)) + (:metaclass db:persistent-class)) + +(defclass can-equip () + ((equipment-table + :initform nil + :type list + :documentation "A PLIST mapping 'equipment slots' to instances of LOOT. Equipment slots are things like :head, :torso, :left-ring, etc") + (equipment-slot-names + :initform +standard-humanoid-equipment+ + :initarg :slot-names + :type (list keyword) + :documentation "The list of slots available to this entity.")) + (:metaclass db:persistent-class)) + +(defclass has-bag () + ((bag + :reader bag + :initform nil + :type list + :documentation "A list of items that this entity is carrying.")) + (:metaclass db:persistent-class)) + +(defclass has-chronicle () + ((chronicle :accessor chronicle :initform nil)) + (:metaclass db:persistent-class) + (:documentation "A chronicle is a general purpose log of events.")) + +(defparameter +standard-humanoid-equipment+ + '(:head :neck :torso :waist :legs :feet :arms :left-fingers :right-fingers + :left-holding :right-holding :cloak) + "The equipment slots for standard humanoids") + +;;; ABSTRACT CLASSES +(defclass game-object (db:store-object has-uid has-chronicle) + () + (:metaclass db:persistent-class)) + +;;; SYSTEM 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)) + + +;; TODO expiration? +(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)) + +;;; GAME CLASSES + +(defclass hero (game-object has-bag can-equip) + ((name + :accessor name + :initarg :name + :initform (error "Heroes must be named") + :type string + :index-type idx:string-unique-index + :index-reader hero-known-as) + (player + :reader player + :initarg :player + :type player + :index-type idx:hash-index + :index-reader player-heroes) + (quest + :accessor quest + :initarg :quest + :initform nil + :type (or nil quest) + :documentation "The quest that this hero is on. A hero may be on only one quest at a time.")) + (:metaclass db:persistent-class)) + + +(defmethod campaign ((hero hero)) + (a:when-let (quest (quest hero)) + (campaign quest))) + +(defclass campaign (game-object) + ((creator + :reader creator + :initarg :creator + :initform (error "campaigns must have a creator") + :type player + :documentation "The player instance of the user who made this campaign.") + (seers + :accessor seers + :initarg :seers + :initform nil + :type (or nil (cons player)) + :documentation "Seers are the people who peer out into their instruments of divination that heroes may go on quests.") + (title + :accessor title + :initarg :title + :initform (error "A campaign needs a title") + :type string) + (rumors + :accessor rumors + :initform nil + :type (or nil (cons rumor)) + :documentation "Beasts, Monsters, and Hazards rumored to be lurking about.")) + (:metaclass db:persistent-class) + (:documentation "A campaign is a container of quests. Campaigns are expected to be engaged with on a particular schedule, and are run by particular people.")) + +(defclass rumor (db:store-object) + ((reporter + :reader reporter + :initarg :reporter + :type player + :documentation "The player who hast reported the vile rumor.") + (reported + :accessor reported + :initform (error "A rumor must contain some reported matter") + :initarg :reported + :type string + :documentation "A description of the supposed peril that awaits heroes in a particular campaign.")) + (:metaclass db:persistent-class) + (:documentation "Transcript of a rumor reported by some player related to a Campaign.")) + +(defclass quest (game-object) + ((campaign + :reader campaign + :initarg :campaign + :initform (error "No quest can fall outside the scope of a campaign.") + :type campaign + :index-type idx:hash-index + :index-reader quests-in-campaign + :documentation "The campaign to which this quest belongs") + (name + :accessor name + :initarg :name + :type string + :initform (format nil "~a" (gensym "QUEST"))) + (horizon-of-hope + :accessor horizon-of-hope + :initarg :deadline + :type integer + :initform nil + :documentation "When all hope becomes lost.") + (inception + :accessor quest-inception + :initform nil + :type (or nil integer) + :documentation "Time at which the quest began.")) + (:metaclass db:persistent-class) + (:documentation "A collection of hazards with a deadline and start date which heroes will attack.")) + +(defclass hazard (game-object) + ((quest + :accessor quest-of + :index-type idx:hash-index + :index-reader hazards-in-quest + :documentation "The quest to which this hazard belongs. Initially it is unbound. It becomes boudn when the hazard is added to a quest.") + (description + :accessor description + :initarg :description + :initform "" + :type string + :documentation "") + (overcomep + :accessor is-overcome + :initform nil + :documentation "indicates whether or not this hazard has been overcome.") + (imminence + :accessor imminence-of + :type priority + :documentation "") + (menace ;; difficulty + :accessor menace-of + :type integer + :documentation "How dangerous the hazard is." )) + (:metaclass db:persistent-class) + (:documentation "Hazard is a superclass for all hazards encountered in a quest. It's chronicle includes data about which heroes fought and which overcame.")) + + + + + diff --git a/src/names.lisp b/src/names.lisp new file mode 100644 index 0000000..8cc64af --- /dev/null +++ b/src/names.lisp @@ -0,0 +1,25 @@ +;;;; names.lisp -- a protocol for getting the names of things, and +;;;; generally referring to objects with strings. + +(in-package :dnd) + +(defgeneric unique-name (object) + (:documentation "Returns a unique name for an object, or NIL if it does not have one.") + (:method ((ob t)) nil)) + +(defmethod unique-name ((campaign campaign)) + (campaign-title campaign)) + +(defmethod unique-name ((hero hero)) + (hero-name hero)) + +(defgeneric urlpath (object) + (:documentation "Return the path to the object given a particular") + (:method ((object has-uid)) + "If the object has a unique human readable name, urlify that name and +incorporate it into the urlpath. Otherwise use the object's uid. + +Returns /inflection/class/identifier." + (format nil "/~a/~a" + (urlify (class-name (class-of object))) + (urlify (or (unique-name object) (uid object)))))) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..20a16d0 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,24 @@ +;;;; package.lisp + +(defpackage #:dnd + (:use #:cl) + (:local-nicknames (#:db #:bknr.datastore) + (#:idx #:bknr.indices) + (#:lzb #:lazybones) + (#:re #:cl-ppcre) + (#:json #:jonathan) + (#:a #:alexandria-2)) + (:import-from #:testiere + #:defun/t) + (:import-from #:lazybones + #:defendpoint*) + (:import-from #:derrida + #:with-plist) + (:import-from #:spinneret + #:with-html + #:with-html-string) + (:import-from #:defclass-std + #:defclass/std) + (:export :boot)) + + diff --git a/src/pages.lisp b/src/pages.lisp new file mode 100644 index 0000000..e7e5673 --- /dev/null +++ b/src/pages.lisp @@ -0,0 +1,17 @@ +;;;; pages.lisp -- html generation functions for dnd + +(in-package :dnd) + + +;;; PAGES + + + + + + + + + + + diff --git a/src/pages/doorkeeper.lisp b/src/pages/doorkeeper.lisp new file mode 100644 index 0000000..560637d --- /dev/null +++ b/src/pages/doorkeeper.lisp @@ -0,0 +1,19 @@ +;;;; pages/doorkeeper.lisp -- announce yourself and enter the hero's tavern + +(in-package :dnd) + +;;; DOORKEEPER CLASS +(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") + (:button :type "submit" "Announce Thyself")) + (:h2 "Eh? Ye need to announce thyeself?") + (:a :href "/join" "Follow me..."))) + diff --git a/src/pages/goddess-shrine.lisp b/src/pages/goddess-shrine.lisp new file mode 100644 index 0000000..3b25e5a --- /dev/null +++ b/src/pages/goddess-shrine.lisp @@ -0,0 +1,13 @@ +;;;; pages/goddess-shrine.lisp + +(in-package :dnd) + +(defrender t ((page (eql :goddess-shrine))) + (with-page (:title "A Sacred Shrine") + (:header + (:h1 "Pray and become a hero...")) + (:form :method "POST" :action "/godess-shrine" + (:label :for "NAME" "Enter the epithet by which the ages shall know thy hero:") + (:input :name "NAME") + (:button :type "submit" "Pray To The Goddess")))) + diff --git a/src/pages/join-gaming-group.lisp b/src/pages/join-gaming-group.lisp new file mode 100644 index 0000000..e758ec7 --- /dev/null +++ b/src/pages/join-gaming-group.lisp @@ -0,0 +1,13 @@ +;;;; pages/join-gaming-group.lisp + +(in-package :dnd) + +(defrender t ((page (eql :join-gaming-group))) + (with-page (:title "Register Player") + (:header + (:h1 "Choose a Nickname Player")) + (:form :method "POST" :action "/register" + (:label :for "NICK" "Choose a nickname. No spaces. Letters, Numbers, and -._") + (:input :name "NICK" :placeholder "superbob") + (:button :type "submit" "Register")))) + diff --git a/src/pages/join.lisp b/src/pages/join.lisp new file mode 100644 index 0000000..b48d102 --- /dev/null +++ b/src/pages/join.lisp @@ -0,0 +1,13 @@ +;;;; pages/join-gaming-group.lisp + +(in-package :dnd) + +(defrender t ((page (eql :join))) + (with-page (:title "Register Player") + (:header + (:h1 "Choose a Nickname Player")) + (:form :method "POST" :action "/join" + (:label :for "NICKNAME" "Choose a nickname. No spaces. Letters, Numbers, and -._") + (:input :name "NICKNAME" :placeholder "superbob") + (:button :type "submit" "Register")))) + diff --git a/src/pages/tavern.lisp b/src/pages/tavern.lisp new file mode 100644 index 0000000..79b0e58 --- /dev/null +++ b/src/pages/tavern.lisp @@ -0,0 +1,20 @@ +;;;; pages/tavern.lisp -- enter the tavern + +(in-package :dnd) + +(defclass/std tavern () + ((player))) + +(defrender t ((tavern tavern)) + (let ((player (player tavern))) + (with-html + (render :details player) + (render :list (player-heroes player)) + (:a :href "/spymaster" "Report a Roguish Rumour...") + ;; (:table + ;; (:tr (:td (:h4 "Your Heroes")) + ;; (:td (:h4 "Your Campaigns"))) + ;; (:tr (:td (:h4 "Gossip & Gab")) + ;; (:td (:h4 "Comrades in Arms")))) + + ))) diff --git a/src/queries.lisp b/src/queries.lisp new file mode 100644 index 0000000..c657979 --- /dev/null +++ b/src/queries.lisp @@ -0,0 +1,34 @@ +;;;; queries.lisp -- query the database + +(in-package :dnd) + +(defun all-heroes () + (db:store-objects-with-class 'hero)) + +(defun player-quests (player) + "Return all quests in which one of player's heroes is engaged." + (remove nil (mapcar #'quest (player-heroes player)))) + +(defun player-campaigns (player) + "Return a list of campaigns one of the players' heroes is involved in." + (mapcar #'campaign (player-quests player) )) + +(defun campaign-heroes (campaign) + "" + ) + +(defun campaign-heros (campaign &key (activep t)) + "All the heros actively involved in this CAMPAIGN. If ACTIVEP, then +only the active quest(s) are considered, otherwise all quests are considered." + (remove-duplicates + (mapcan #'heroes-on-quest + (if activep + (remove-if-not #'quest-startedp (quests-in-campaign campaign)) + (quests-in-campaign campaign))))) + +(defun fetch-comrades (player &key (activep t)) + "Returns all the heroes in any one of the player's campaigns. If +ACTIVEP, then only heroes involved in active quests are returned." + (remove-duplicates + (loop :for campaign :in (player-campaigns player) + :nconc (campaign-heros campaign :activep activep)))) diff --git a/src/render.lisp b/src/render.lisp new file mode 100644 index 0000000..140e1ec --- /dev/null +++ b/src/render.lisp @@ -0,0 +1,23 @@ +;;;; render.lisp -- render protocol and tools + +(in-package :dnd) + +(defgeneric render (view object &key) + (:documentation "Render OBJECT as VIEW. VIEW could be anything, but it is intended to +be a keyword for usin in EQL method specializers.")) + +(defmacro defrender (view (spec &rest kwargs) &body body) + "A helper macro for defining specializations of render." + (let ((viewvar (gensym))) + `(defmethod render ((,viewvar ,(if (eq t view) t `(eql ,view))) ,spec &key ,@kwargs) + ,@body))) + +(defmacro with-page ((&key title) &body body) + "A helper macro fordefining some standard page boilerplate." + `(with-html-string + (:doctype) + (:html + (:head + (:title ,title)) + (:body + ,@body)))) diff --git a/src/transactions.lisp b/src/transactions.lisp new file mode 100644 index 0000000..ad9c9e8 --- /dev/null +++ b/src/transactions.lisp @@ -0,0 +1,22 @@ +;;;; transactions.lisp -- data store transactions for dnd + +(in-package :dnd) + +(defun birth-from-the-goddess-loins (player name) + (db:with-transaction () + (make-instance 'hero :name name :player player))) + +(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))) + +(defun create-campaign (player title) + (db:with-transaction () + (make-instance 'campaign :title title :creator player))) diff --git a/src/utilities.lisp b/src/utilities.lisp new file mode 100644 index 0000000..1e16931 --- /dev/null +++ b/src/utilities.lisp @@ -0,0 +1,68 @@ +;;;; utilities -- nuff said + +(in-package :dnd) + + +(let ((host (uiop:hostname)) + (count 0)) + (defun nuid () + "Generates a Nearly Universal ID" + (format nil "~36r" + (sxhash + (list + (incf count) + host + (get-universal-time)))))) + +(defun hash-string (plaintext salt) + "Hash plaintext using SALT" + (flexi-streams:octets-to-string + (ironclad:digest-sequence + :sha3 + (flexi-streams:string-to-octets (concatenate 'string salt plaintext) + :external-format :utf-8)) + :external-format :latin1)) + +(defparameter +user-nick-chars+ "0123456789abcdefghijklmnopqrstuvwxyz-._") + +(defun/t valid-nick-p (nick) + :tests + (eql ("??????") nil) + (eql ("โš”") nil) + (eql ("cool_beans") t) + (eql ("COOOL_BEANS") t) + (eql ("COOL beans") nil) + :end + (unless (zerop (length nick)) + (loop :for char :across nick + :always (find char +user-nick-chars+ + :test #'char-equal)))) + +(defun/t asciip (thing) + "T if THING is an ASCII character, NIL otherwise." + :tests + (eql (#\x) t) + (eql (#\รถ) nil) + (eql (#\nul) t) + (eql (#\return) t) + (eql (nil) nil) + (eql ("foo") nil) + :end + (and (characterp thing) + (<= 0 (char-code thing) 127))) + +(defun/t urlify (string &optional (sub #\-)) + "Canonical transformation for strings that makes them appropriate for urls." + :tests + (equal ("THIS IS COOL") "this-is-cool") + (equal ("This is cool") "this-is-cool") + (equal ("Mc'this is ฮบoรถl ") "mc-this-is-o-l") + :end + (str:join + sub + (str:split-omit-nulls + #\space + (substitute-if-not + #\space + (a:conjoin #'asciip #'alphanumericp) + (string-downcase string))))) diff --git a/src/views/campaign.lisp b/src/views/campaign.lisp new file mode 100644 index 0000000..5e1498a --- /dev/null +++ b/src/views/campaign.lisp @@ -0,0 +1,8 @@ +;;;; views/campaign.lisp -- views of for campaign instances + +(in-package :dnd) + + +(defrender :inline ((campaign campaign)) + (with-html + (:a :href (urlpath campaign) (title campaign)))) diff --git a/src/views/components.lisp b/src/views/components.lisp new file mode 100644 index 0000000..95ed062 --- /dev/null +++ b/src/views/components.lisp @@ -0,0 +1,33 @@ +;;;; views/components.lisp -- reusable components + +(in-package :dnd) + +;;; LIST DATA + +(defrender :list ((data list) (class "listview") (item-class "listitem")) + "A catch all for rendering lists of renderable data items as unordered +lists. CLASS is the lass string for the containing list. ITEM-CLASS is +the class string for the contained list items." + (with-html + (:ol :class class + (dolist (item data) + (:li :class item-class (render :list-item item)))))) + +(defrender :horiz-list ((data list) (class "hlistview") (item-class "listitem")) + (with-html + (:ol :class class + (dolist (item data) + (:li :calss item-class (render :list-item item)))))) + +;;;; PAGE ELEMENTS + +(defun navbar () + (with-html + (:nav :class "navbar" :aria-label "Navigation" + (:div :class "logo" :aria-label "DND logo" "DND") + (:ul :class "nav-links" :aria-label "Nav links" + (:li (:a :href "/hero" :aria-label "Hero profile" "๐Ÿง")) + (:li (:a :href "/inventory" :aria-label "Inventory" "๐ŸŽ’")) + (:li (:a :href "/quests" :aria-label "Quests" "๐Ÿ“œ")) + (:li (:a :href "/tavern" :aria-label "Tavern" "๐Ÿบ")))))) + diff --git a/src/views/hazard.lisp b/src/views/hazard.lisp new file mode 100644 index 0000000..a842c6f --- /dev/null +++ b/src/views/hazard.lisp @@ -0,0 +1,4 @@ +;;;; hazard.lisp -- views of hazard insances + +(in-package :dnd) + diff --git a/src/views/hero.lisp b/src/views/hero.lisp new file mode 100644 index 0000000..7387901 --- /dev/null +++ b/src/views/hero.lisp @@ -0,0 +1,11 @@ +;;;; views/hero.lisp + +(in-package :dnd) + +(defrender :list-item ((hero hero)) + (with-html + (with-slots ((name campaign) hero) + (:p name "the" (hero-class hero) (hero-title hero) + (when campaign + (:span "who is off in the campaign") + (:span (render :inline campaign))))))) diff --git a/src/views/player.lisp b/src/views/player.lisp new file mode 100644 index 0000000..087848e --- /dev/null +++ b/src/views/player.lisp @@ -0,0 +1,8 @@ +;;;; views/player.lisp + +(in-package :dnd) + +(defrender :details ((player player)) + (with-html + (:div :class "player details" + (:h3 "Welcome " (nickname player))))) diff --git a/src/views/quest.lisp b/src/views/quest.lisp new file mode 100644 index 0000000..0312dba --- /dev/null +++ b/src/views/quest.lisp @@ -0,0 +1,4 @@ +;;;; views/quest.lisp + +(in-package :dnd) + diff --git a/src/views/rumor.lisp b/src/views/rumor.lisp new file mode 100644 index 0000000..90f56ae --- /dev/null +++ b/src/views/rumor.lisp @@ -0,0 +1,4 @@ +;;;; views/rumor.lisp + +(in-package :dnd) + diff --git a/transactions.lisp b/transactions.lisp deleted file mode 100644 index acfa8c2..0000000 --- a/transactions.lisp +++ /dev/null @@ -1,22 +0,0 @@ -;;;; transactions.lisp -- data store transactions for dnd - -(in-package :dnd) - -(defun birth-from-the-goddess-loins (player name) - (db:with-transaction () - (make-instance 'hero :name name :player player))) - -(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 :nick nick))) - -(defun create-campaign (player title) - (db:with-transaction () - (make-instance 'campaign :title title :creator player))) diff --git a/utilities.lisp b/utilities.lisp deleted file mode 100644 index fee21fe..0000000 --- a/utilities.lisp +++ /dev/null @@ -1,68 +0,0 @@ -;;;; utilities -- nuff said - -(in-package :dnd) - - -(let ((host (uiop:hostname)) - (count 0)) - (defun nuid () - "Generates a Nearly Universal ID" - (format nil "~36r" - (sxhash - (list - (incf count) - host - (get-universal-time)))))) - -(defun hash-string (plaintext salt) - "Hash plaintext using SALT" - (flexi-streams:octets-to-string - (ironclad:digest-sequence - :sha3 - (flexi-streams:string-to-octets (concatenate 'string salt plaintext) - :external-format :utf-8)) - :external-format :latin1)) - -(defparameter +user-nick-chars+ "0123456789abcdefghijklmnopqrstuvwxyz-._") - -(defun/t valid-nick-p (nick) - :tests - (eql ("??????") nil) - (eql ("โš”") nil) - (eql ("cool_beans") t) - (eql ("COOOL_BEANS") t) - (eql ("COOL beans") nil) - :end - (unless (zerop (length nick)) - (loop :for char :across nick - :always (find char +user-nick-chars+ - :test #'char-equal)))) - -(defun/t asciip (thing) - "T if THING is an ASCII character, NIL otherwise." - :tests - (eql (#\x) t) - (eql (#\รถ) nil) - (eql (#\nul) t) - (eql (#\return) t) - (eql (nil) nil) - (eql ("foo") nil) - :end - (and (characterp thing) - (<= 0 (char-code thing) 127))) - -(defun/t urlify (string) - "Canonical transformation for strings that makes them appropriate for urls." - :tests - (equal ("THIS IS COOL") "this-is-cool") - (equal ("This is cool") "this-is-cool") - (equal ("Mc'this is ฮบoรถl ") "mc-this-is-o-l") - :end - (str:join - #\- - (str:split-omit-nulls - #\space - (substitute-if-not - #\space - (a:conjoin #'asciip #'alphanumericp) - (string-downcase string))))) -- cgit v1.2.3