Add: with-checked-plist macro, some validtators, and refactored

3 files changed, 74 insertions, 7 deletions

diff --git a/endpoints.lisp b/endpoints.lisp
index 6dde37e..e33a362 100644
--- a/endpoints.lisp
+++ b/endpoints.lisp
@@ -58,6 +58,36 @@ I.e. It should be called within the scope of a request handler."
        (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
 
 
@@ -84,14 +114,11 @@ I.e. It should be called within the scope of a request handler."
 (defendpoint* :get "/register" () ()
   (register))
 
-(defun check-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"))))
+
 
 (defendpoint* :post "/register" () ()
-  (with-plist ((nick :nick)) (lzb:request-body)
-    (check-valid-nick nick)
+  "Registers a new player"
+  (with-checked-plist ((nick :nick 'a-valid-nick)) (lzb:request-body)
     (register-player nick)
     (redirect-to "/tavern-door")))
 
@@ -107,6 +134,13 @@ I.e. It should be called within the scope of a request handler."
 
 (defendpoint* :post "/godess-shrine" () ()
   (with-session (player)
-    (with-plist ((name :name)) (lzb:request-body)
+    (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/transactions.lisp b/transactions.lisp
index 35e817c..acfa8c2 100644
--- a/transactions.lisp
+++ b/transactions.lisp
@@ -16,3 +16,7 @@
 (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
index 7acdbca..fee21fe 100644
--- a/utilities.lisp
+++ b/utilities.lisp
@@ -37,3 +37,32 @@
     (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)))))