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
|
;;;; app.lisp -- lazybones application definition and helpers
(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-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))))
(defun get-checkboxes-from-body (name &optional (mapper #'object-with-uid))
(loop :for (key val) :on (lzb:request-body) :by #'cddr
:when (string-equal key name)
:collect (funcall mapper val)))
;;; VALIDATOR TRANSFORMS
(defmacro define-id-plucker (class)
(let ((function-name
(intern (format nil "~a-~a-WITH-ID"
(if (starts-with-vowel-p (symbol-name class))
"AN" "A")
class)
:dnd)))
`(defun ,function-name (id)
(let ((object (object-with-uid (string-upcase id))))
(unless (typep object ',class)
(lzb:http-err 404 (format nil "No ~a with id = ~a" ',class id)))
object))))
(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)
|
