1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
;;;; 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 "/goddess-shrine" () ()
(with-session (player)
(render (page-render-mode) :goddess-shrine)))
(defendpoint* :post "/goddess-shrine" () ()
(with-session (player)
(with-checked-plist ((name :name 'a-short-string)) (lzb:request-body)
(birth-from-the-goddess-loins player name)
(redirect-to "/tavern"))))
(defendpoint* :get "/adventure-awaits" () ()
(with-session (player)
(render (page-render-mode)
(make-instance 'adventure-awaits
:possible-seers (remove player (all-players))))))
(defendpoint* :post "/adventure-awaits" () ()
(with-session (creator)
(with-plist ((title :title) (description :description)) (lzb:request-body)
(let ((possible-seers
(loop :for (key val) :on (lzb:request-body) :by #'cddr
:when (string-equal key "POSSIBLE-SEER")
:collect (object-with-uid val))))
(redirect-to
(urlpath
(create-adventure creator title
:description description
:seers possible-seers)))))))
(defun an-adventure-with-id (id)
(let ((object (object-with-uid (string-upcase id))))
(unless (typep object 'adventure)
(lzb:http-err 404))
object))
(defendpoint* :get "/adventure/:adventure an-adventure-with-id:/:title:" () ()
(with-session (player)
(render (page-render-mode)
adventure))) ;; for now, render raw adventure.
|
