diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/build.lisp | 16 | ||||
| -rw-r--r-- | src/dnd.lisp | 17 | ||||
| -rw-r--r-- | src/endpoints.lisp | 139 | ||||
| -rw-r--r-- | src/flash.lisp | 71 | ||||
| -rw-r--r-- | src/init.lisp | 12 | ||||
| -rw-r--r-- | src/model.lisp | 228 | ||||
| -rw-r--r-- | src/names.lisp | 25 | ||||
| -rw-r--r-- | src/package.lisp | 24 | ||||
| -rw-r--r-- | src/pages.lisp | 17 | ||||
| -rw-r--r-- | src/pages/doorkeeper.lisp | 19 | ||||
| -rw-r--r-- | src/pages/goddess-shrine.lisp | 13 | ||||
| -rw-r--r-- | src/pages/join-gaming-group.lisp | 13 | ||||
| -rw-r--r-- | src/pages/join.lisp | 13 | ||||
| -rw-r--r-- | src/pages/tavern.lisp | 20 | ||||
| -rw-r--r-- | src/queries.lisp | 34 | ||||
| -rw-r--r-- | src/render.lisp | 23 | ||||
| -rw-r--r-- | src/transactions.lisp | 22 | ||||
| -rw-r--r-- | src/utilities.lisp | 68 | ||||
| -rw-r--r-- | src/views/campaign.lisp | 8 | ||||
| -rw-r--r-- | src/views/components.lisp | 33 | ||||
| -rw-r--r-- | src/views/hazard.lisp | 4 | ||||
| -rw-r--r-- | src/views/hero.lisp | 11 | ||||
| -rw-r--r-- | src/views/player.lisp | 8 | ||||
| -rw-r--r-- | src/views/quest.lisp | 4 | ||||
| -rw-r--r-- | src/views/rumor.lisp | 4 |
25 files changed, 846 insertions, 0 deletions
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) + |