summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/build.lisp16
-rw-r--r--src/dnd.lisp17
-rw-r--r--src/endpoints.lisp139
-rw-r--r--src/flash.lisp71
-rw-r--r--src/init.lisp12
-rw-r--r--src/model.lisp228
-rw-r--r--src/names.lisp25
-rw-r--r--src/package.lisp24
-rw-r--r--src/pages.lisp17
-rw-r--r--src/pages/doorkeeper.lisp19
-rw-r--r--src/pages/goddess-shrine.lisp13
-rw-r--r--src/pages/join-gaming-group.lisp13
-rw-r--r--src/pages/join.lisp13
-rw-r--r--src/pages/tavern.lisp20
-rw-r--r--src/queries.lisp34
-rw-r--r--src/render.lisp23
-rw-r--r--src/transactions.lisp22
-rw-r--r--src/utilities.lisp68
-rw-r--r--src/views/campaign.lisp8
-rw-r--r--src/views/components.lisp33
-rw-r--r--src/views/hazard.lisp4
-rw-r--r--src/views/hero.lisp11
-rw-r--r--src/views/player.lisp8
-rw-r--r--src/views/quest.lisp4
-rw-r--r--src/views/rumor.lisp4
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)
+