Skip to content
Browse files

remove tabs and change to spaces

  • Loading branch information...
1 parent d283f08 commit 2b074bec9766b1854cd05233fb0f14d3ec51f6b0 @vii committed
Showing with 5,056 additions and 5,058 deletions.
  1. +130 −130 src/blog/blog.lisp
  2. +88 −88 src/blog/entry.lisp
  3. +31 −31 src/blog/feed.lisp
  4. +108 −108 src/datastore/datastore.lisp
  5. +11 −11 src/game/card.lisp
  6. +21 −21 src/game/coins.lisp
  7. +4 −4 src/game/controllers.lisp
  8. +66 −66 src/game/framework.lisp
  9. +2 −2 src/game/generic.lisp
  10. +13 −13 src/game/unassigned-controller.lisp
  11. +46 −46 src/game/web-messages.lisp
  12. +182 −182 src/game/web.lisp
  13. +59 −59 src/http/dispatcher.lisp
  14. +8 −8 src/http/encoding.lisp
  15. +15 −15 src/http/headers.lisp
  16. +105 −105 src/http/request.lisp
  17. +128 −128 src/http/serve.lisp
  18. +19 −19 src/http/servestate.lisp
  19. +71 −71 src/io/con.lisp
  20. +36 −36 src/io/epoll.lisp
  21. +11 −11 src/io/mux.lisp
  22. +1 −1 src/io/openssl.lisp
  23. +56 −56 src/io/posix-socket.lisp
  24. +42 −42 src/io/protocol.lisp
  25. +31 −31 src/io/recvbuf.lisp
  26. +10 −10 src/io/repeater.lisp
  27. +70 −70 src/io/sendbuf.lisp
  28. +27 −27 src/io/ssl.lisp
  29. +125 −125 src/io/syscalls.lisp
  30. +67 −67 src/lib/byte-vector.lisp
  31. +18 −18 src/lib/callcc.lisp
  32. +68 −68 src/lib/macros.lisp
  33. +85 −85 src/lib/my.lisp
  34. +16 −16 src/lib/once-only.lisp
  35. +38 −38 src/lib/one-liners.lisp
  36. +6 −7 src/lib/quick-queue.lisp
  37. +33 −33 src/lib/strcat.lisp
  38. +9 −9 src/lib/superquote.lisp
  39. +38 −38 src/lib/timeout.lisp
  40. +44 −44 src/lib/utils.lisp
  41. +178 −178 src/ml/css.lisp
  42. +61 −61 src/ml/define-dtd.lisp
  43. +8 −8 src/ml/js.lisp
  44. +20 −20 src/ml/output.lisp
  45. +1 −1 src/ml/rss.lisp
  46. +43 −43 src/packages.lisp
  47. +25 −25 src/small-games/nash-bargain.lisp
  48. +31 −32 src/small-games/prisoners-dilemma.lisp
  49. +17 −17 src/small-games/roshambo.lisp
  50. +13 −13 src/small-games/ultimatum.lisp
  51. +30 −30 src/survey/survey.lisp
  52. +42 −42 src/truc/robots.lisp
  53. +64 −64 src/truc/truc.lisp
  54. +29 −29 src/truc/web.lisp
  55. +83 −83 src/webapp/actions.lisp
  56. +56 −56 src/webapp/channel.lisp
  57. +1 −1 src/webapp/frame.lisp
  58. +146 −146 src/webapp/js-library.lisp
  59. +2 −2 src/webapp/list-channel.lisp
  60. +10 −10 src/webapp/message-channel.lisp
  61. +1,980 −1,980 src/webapp/names.lisp
  62. +50 −50 src/webapp/page.lisp
  63. +5 −5 src/webapp/simple-channel.lisp
  64. +36 −36 src/webapp/site.lisp
  65. +49 −49 src/webapp/webapp.lisp
  66. +55 −55 t/http.lisp
  67. +47 −47 t/io.lisp
  68. +36 −36 t/regex.lisp
View
260 src/blog/blog.lisp
@@ -27,35 +27,35 @@
(my-defun blog read-in ()
(with-site ((my site))
(let ((old-entries (or (my entries-table) (make-hash-table :test 'equalp))))
- (setf
+ (setf
(my entries-table) (make-hash-table :test 'equalp)
- (my entries)
+ (my entries)
(sort
- (iter:iter (iter:for path in (cl-fad:list-directory (my dir)))
- (let ((filename (force-string path)))
- (unless (or (find #\# filename) (find #\~ filename))
- (let ((entry (read-in-entry me (file-namestring filename))))
- (iter:collect entry)))))
- #'> :key #'entry-time))
+ (iter:iter (iter:for path in (cl-fad:list-directory (my dir)))
+ (let ((filename (force-string path)))
+ (unless (or (find #\# filename) (find #\~ filename))
+ (let ((entry (read-in-entry me (file-namestring filename))))
+ (iter:collect entry)))))
+ #'> :key #'entry-time))
(loop for entry in (my entries)
- for old = (gethash (entry-index-name entry) old-entries)
- do
- (if old
- (setf (entry-score entry) (entry-score old)
- (entry-score-update-time entry) (entry-score-update-time old))
- (entry-set-score entry))
- (setf (gethash (entry-index-name entry) (my entries-table)) entry))
+ for old = (gethash (entry-index-name entry) old-entries)
+ do
+ (if old
+ (setf (entry-score entry) (entry-score old)
+ (entry-score-update-time entry) (entry-score-update-time old))
+ (entry-set-score entry))
+ (setf (gethash (entry-index-name entry) (my entries-table)) entry))
(my set-page)))
me)
(defun split-into-list-by-comma (str)
(match-split (progn (* (space)) "," (* (space)))
- str))
+ str))
(my-defun blog ready-entries (&key (age (get-universal-time)) tags)
(loop for e in (my entries)
- when (and (entry-front-page-p e tags) (<= (entry-time e) age))
- collect e))
+ when (and (entry-front-page-p e tags) (<= (entry-time e) age))
+ collect e))
(my-defun blog url (name)
(byte-vector-cat (my link-base) name))
@@ -78,97 +78,97 @@
(with-ml-output
(<link :rel "alternate" :type "application/atom+xml" :href (my atom-feed-url))
- ; disable the RSS feed as RSS wants to have absolute URLs
- ; (<link :rel "alternate" :type "application/rss+xml" :href (my rss-feed-url)))
+ ; disable the RSS feed as RSS wants to have absolute URLs
+ ; (<link :rel "alternate" :type "application/rss+xml" :href (my rss-feed-url)))
))
(my-defun blog set-page ()
(with-site ((my site))
(defpage-lambda-blog (my atom-feed-url)
- (lambda (tags)
- (my atom-feed :tags (split-into-list-by-comma tags))))
+ (lambda (tags)
+ (my atom-feed :tags (split-into-list-by-comma tags))))
(defpage-lambda-blog (my rss-feed-url)
- (lambda ()
- (my rss-feed)))
-
- (defpage-lambda (my admin-url)
- (lambda (password entry-name)
- (webapp "Blog administration"
- (<form :method :post
- :action (my admin-url)
- (<p "Password "
- (<input :type :text :name "password" )
- (<input :class "plain-submit" :type :submit :value "")))
- (when (and password (equal (force-string password) (force-string (my admin-password))))
- (let ((comments
- (if entry-name
- (datastore-retrieve-indexed 'comment 'entry-index-name entry-name)
- (remove-if-not (lambda (comment)
- (and (typecase (comment-entry-index-name comment)
- ((or string byte-vector) t))
- (if-match-bind ((= (my comment-index-prefix)) ":")
- (comment-entry-index-name comment))))
- (datastore-retrieve-all 'comment)))))
- (loop for c in (sort (copy-seq comments) #'> :key #'comment-time)
- do (<div :class "comment-admin"
- (let ((c c))
- (html-action-form "Edit comment"
- ((text (comment-text c) :type <textarea)
- (author (comment-author c)))
- (setf (comment-text c) text
- (comment-author c) author))
- (html-action-link "Delete"
- (datastore-delete c))))))))))
+ (lambda ()
+ (my rss-feed)))
+
+ (defpage-lambda (my admin-url)
+ (lambda (password entry-name)
+ (webapp "Blog administration"
+ (<form :method :post
+ :action (my admin-url)
+ (<p "Password "
+ (<input :type :text :name "password" )
+ (<input :class "plain-submit" :type :submit :value "")))
+ (when (and password (equal (force-string password) (force-string (my admin-password))))
+ (let ((comments
+ (if entry-name
+ (datastore-retrieve-indexed 'comment 'entry-index-name entry-name)
+ (remove-if-not (lambda (comment)
+ (and (typecase (comment-entry-index-name comment)
+ ((or string byte-vector) t))
+ (if-match-bind ((= (my comment-index-prefix)) ":")
+ (comment-entry-index-name comment))))
+ (datastore-retrieve-all 'comment)))))
+ (loop for c in (sort (copy-seq comments) #'> :key #'comment-time)
+ do (<div :class "comment-admin"
+ (let ((c c))
+ (html-action-form "Edit comment"
+ ((text (comment-text c) :type <textarea)
+ (author (comment-author c)))
+ (setf (comment-text c) text
+ (comment-author c) author))
+ (html-action-link "Delete"
+ (datastore-delete c))))))))))
(defpage-lambda-blog (my post-comment-url)
- (lambda (text author entry-name keep-this-empty .javascript.)
- (let ((entry-name (force-string entry-name)))
- (let ((success
- (when (and
- (zerop (length keep-this-empty))
- text
- (not (zerop (length text)))
- (< (length text) +max-comment-length+)
- (not (if-match-bind (t (or "[url=" "[URL=")) text))
- (not (equalp
- text
- (ignore-errors (comment-text (first (datastore-retrieve-indexed 'comment 'entry-index-name entry-name)))))))
- (let ((entry (gethash entry-name (my entries-table))))
- (when entry
- (let ((comment
- (make-comment
- :author author
- :text text
- :trace-details (tpd2.http:servestate-origin*)
- :entry-index-name entry-name)))
- (entry-update-score entry (comment-score comment)))
- (channel-notify (entry-channel entry)))
- t))))
- (cond
- (.javascript.
- (if success
- (webapp-respond-ajax-body)
- (tpd2.io:with-sendbuf ()
- (js-to-bv (alert "Comment rejected by spam protection.")))))
- (success
- (webapp "Comment accepted" (<p "Thank you.")))
- (t
- (webapp "Comment rejected by spam protection"
- (<p "Sorry for the inconvenience. Please contact the blog owner with a description of the problem."))))))))
-
- (defpage-lambda-blog (my link-base)
- (lambda ()
- (webapp ((with-ml-output (my name) ": popular posts")
- :head-contents
- (my feed-head-contents))
- (my front-page))))
-
- (defpage-lambda-blog (my latest-url)
- (lambda ()
- (webapp ((my name)
- :head-contents
- (my feed-head-contents))
- (my latest-page))))))
+ (lambda (text author entry-name keep-this-empty .javascript.)
+ (let ((entry-name (force-string entry-name)))
+ (let ((success
+ (when (and
+ (zerop (length keep-this-empty))
+ text
+ (not (zerop (length text)))
+ (< (length text) +max-comment-length+)
+ (not (if-match-bind (t (or "[url=" "[URL=")) text))
+ (not (equalp
+ text
+ (ignore-errors (comment-text (first (datastore-retrieve-indexed 'comment 'entry-index-name entry-name)))))))
+ (let ((entry (gethash entry-name (my entries-table))))
+ (when entry
+ (let ((comment
+ (make-comment
+ :author author
+ :text text
+ :trace-details (tpd2.http:servestate-origin*)
+ :entry-index-name entry-name)))
+ (entry-update-score entry (comment-score comment)))
+ (channel-notify (entry-channel entry)))
+ t))))
+ (cond
+ (.javascript.
+ (if success
+ (webapp-respond-ajax-body)
+ (tpd2.io:with-sendbuf ()
+ (js-to-bv (alert "Comment rejected by spam protection.")))))
+ (success
+ (webapp "Comment accepted" (<p "Thank you.")))
+ (t
+ (webapp "Comment rejected by spam protection"
+ (<p "Sorry for the inconvenience. Please contact the blog owner with a description of the problem."))))))))
+
+ (defpage-lambda-blog (my link-base)
+ (lambda ()
+ (webapp ((with-ml-output (my name) ": popular posts")
+ :head-contents
+ (my feed-head-contents))
+ (my front-page))))
+
+ (defpage-lambda-blog (my latest-url)
+ (lambda ()
+ (webapp ((my name)
+ :head-contents
+ (my feed-head-contents))
+ (my latest-page))))))
(my-defun blog link-to-latest ()
(tpd2.http:with-http-params (tags age)
@@ -182,40 +182,40 @@
(my-defun blog front-page ()
(let ((entries (my ready-entries-http)) (count 24))
(let ((entries (sort (copy-list entries) #'> :key #'entry-score)))
- (<div :class "blog-front-page"
- (my link-to-latest)
-
- (<div :class "blog-front-page-entries"
- (let* (
- (entries (loop for e in entries repeat count collect e))
- (total-score (loop for e in entries summing (entry-score e)))
- (score-mul (/ (length entries) (max 1 total-score)))
- (reverse-entries (reverse entries)))
- (loop for entry in entries
- repeat (/ count 3)
- do
- (with-ml-output (entry-headline-ml entry score-mul)
- (loop repeat 2 do
- (with-ml-output (entry-headline-ml (pop reverse-entries) score-mul))))
- )))
-
- (my link-to-latest)))))
+ (<div :class "blog-front-page"
+ (my link-to-latest)
+
+ (<div :class "blog-front-page-entries"
+ (let* (
+ (entries (loop for e in entries repeat count collect e))
+ (total-score (loop for e in entries summing (entry-score e)))
+ (score-mul (/ (length entries) (max 1 total-score)))
+ (reverse-entries (reverse entries)))
+ (loop for entry in entries
+ repeat (/ count 3)
+ do
+ (with-ml-output (entry-headline-ml entry score-mul)
+ (loop repeat 2 do
+ (with-ml-output (entry-headline-ml (pop reverse-entries) score-mul))))
+ )))
+
+ (my link-to-latest)))))
(my-defun blog latest-page ()
(tpd2.http:with-http-params (tags)
(let ((entries (my ready-entries-http)) (count 10))
(<div :class "blog"
- (loop while entries
- repeat count
- do
- (let ((entry (pop entries)))
- (<h2 (<a :href (entry-url-path entry) (entry-title entry)))
- (output-object-to-ml entry)))
- (when entries
- (<h3 :class "next-entries"
- (<a :href (page-link (my latest-url) :age (force-byte-vector (entry-time (first entries))) :tags (force-byte-vector tags)) "Older entries (" (length entries) " remaining)")))))))
+ (loop while entries
+ repeat count
+ do
+ (let ((entry (pop entries)))
+ (<h2 (<a :href (entry-url-path entry) (entry-title entry)))
+ (output-object-to-ml entry)))
+ (when entries
+ (<h3 :class "next-entries"
+ (<a :href (page-link (my latest-url) :age (force-byte-vector (entry-time (first entries))) :tags (force-byte-vector tags)) "Older entries (" (length entries) " remaining)")))))))
(my-defun blog last-updated ()
(loop for e in (my entries)
- when (entry-front-page-p e)
- maximizing (entry-time e)))
+ when (entry-front-page-p e)
+ maximizing (entry-time e)))
View
176 src/blog/entry.lisp
@@ -11,26 +11,26 @@
(with-shorthand-accessor (my comment)
(print-unreadable-object (comment stream :type t)
(format stream "~S by ~S/~A at ~A"
- (force-string (my text))
- (force-string (my author))
- (force-string (my trace-details))
- (time-string (my time))))))
+ (force-string (my text))
+ (force-string (my author))
+ (force-string (my trace-details))
+ (time-string (my time))))))
(defun split-into-paragraphs (str)
(match-split (progn #\Newline (* (or #\Space #\Tab #\Return)) #\Newline)
- str))
+ str))
(defun split-into-paragraphs-by-single-line (str)
(when str
- (match-split #\Newline
- str)))
+ (match-split #\Newline
+ str)))
(my-defun comment 'object-to-ml ()
(<div :class "comment"
- (loop for p in (split-into-paragraphs-by-single-line (my text)) do (<p p))
+ (loop for p in (split-into-paragraphs-by-single-line (my text)) do (<p p))
- (<p :class "time" "Posted " (time-string (my time)) " by " (<span :class "author" (my author)))))
+ (<p :class "time" "Posted " (time-string (my time)) " by " (<span :class "author" (my author)))))
(defvar *score-decay* (exp (/ (log 1/2) (* 6 30 24 60 60))))
(defvar *comment-score* 8)
@@ -57,26 +57,26 @@
(let ((score (loop for c in (my comments) summing (comment-score c))))
(incf score (* *entry-score* (score-decay (my time))))
(setf (my score) score
- (my score-update-time) (get-universal-time))))
+ (my score-update-time) (get-universal-time))))
(my-defun entry update-score (&optional (inc 0))
(unless (my score) (my set-score))
(setf (my score) (+ inc (* (my score) (score-decay (my score-update-time))))
- (my score-update-time) (get-universal-time)))
+ (my score-update-time) (get-universal-time)))
(defmyclass (entry-channel (:include simple-channel))
entry)
(my-defun entry-channel 'simple-channel-body-ml ()
(<div :class "blog-entry-comments"
- (output-object-to-ml
- (let (ret)
- (loop for c in (entry-comments (my entry)) repeat 50 do (push c ret))
- ret))))
+ (output-object-to-ml
+ (let (ret)
+ (loop for c in (entry-comments (my entry)) repeat 50 do (push c ret))
+ ret))))
(defun time-string (&optional (ut (get-universal-time)))
(multiple-value-bind
- (second minute hour date month year)
+ (second minute hour date month year)
(decode-universal-time ut 0)
(format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D GMT" year month date hour minute second)))
@@ -86,10 +86,10 @@
(my-defun entry front-page-p (&optional tags)
(let ((now (get-universal-time)))
(and (>= now (my time))
- (or (not (my expiry-time)) (>= (my expiry-time) now))
-
- (or (not tags)
- (intersection (my tags) tags :test #'equalp)))))
+ (or (not (my expiry-time)) (>= (my expiry-time) now))
+
+ (or (not tags)
+ (intersection (my tags) tags :test #'equalp)))))
(my-defun entry url-path ()
(byte-vector-cat (its link-base (my blog)) (my name)))
@@ -102,63 +102,63 @@
(my-defun entry story-ml ()
(<div :class "blog-entry-story"
- (loop for p in (my paragraphs)
- do (<p (output-raw-ml p)))))
+ (loop for p in (my paragraphs)
+ do (<p (output-raw-ml p)))))
(my-defun entry comments ()
(datastore-retrieve-indexed 'comment 'entry-index-name (my index-name)))
(my-defun entry comment-ml ()
(<div :class "blog-entry-post-comment"
- (html-action-form-collapsed ("Post a comment" :action-link (blog-post-comment-url (my blog)))
- ((text nil :type <textarea :reset "")
- (author (byte-vector-cat "Anonymous from " (tpd2.http:servestate-origin*)))
- (entry-name (my index-name) :type :hidden)
- (keep-this-empty nil :type :hidden)))))
+ (html-action-form-collapsed ("Post a comment" :action-link (blog-post-comment-url (my blog)))
+ ((text nil :type <textarea :reset "")
+ (author (byte-vector-cat "Anonymous from " (tpd2.http:servestate-origin*)))
+ (entry-name (my index-name) :type :hidden)
+ (keep-this-empty nil :type :hidden)))))
(my-defun entry 'object-to-ml ()
(my update-score 1)
(<div :class "blog-entry"
- (<p :class "time" "Posted " (time-string (my time)))
- (let ((v (length (its subscribers (my channel)))))
- (unless (zerop v)
- (<p :class "viewers" v " watching live")))
- (my story-ml)
- (my channel)
- (my comment-ml)))
+ (<p :class "time" "Posted " (time-string (my time)))
+ (let ((v (length (its subscribers (my channel)))))
+ (unless (zerop v)
+ (<p :class "viewers" v " watching live")))
+ (my story-ml)
+ (my channel)
+ (my comment-ml)))
(defvar *age-units* `(("year" ,(* 365.25 24 60 60))
- ("week" ,(* 7 24 60 60))
- ("day" ,(* 24 60 60))
- ("hour" ,(* 60 60))
- ("minute" 60)
- ("second" 1)))
+ ("week" ,(* 7 24 60 60))
+ ("day" ,(* 24 60 60))
+ ("hour" ,(* 60 60))
+ ("minute" 60)
+ ("second" 1)))
(defun friendly-age-string (time)
(let ((age (- (get-universal-time) time)))
(let ((units *age-units*))
- (loop
- for value = (cadr (first units))
- while (and (cdr units) (< age value))
- do (pop units))
- (destructuring-bind (name value)
- (first units)
- (let ((v (floor age value)))
- (format nil "~R ~A~P" v name v))))))
+ (loop
+ for value = (cadr (first units))
+ while (and (cdr units) (< age value))
+ do (pop units))
+ (destructuring-bind (name value)
+ (first units)
+ (let ((v (floor age value)))
+ (format nil "~R ~A~P" v name v))))))
(my-defun entry headline-ml (score-mul)
(<div :class "blog-front-page-entry"
- :style
- (css-attrib
- :max-width ((format nil "~$%" (* 100 (min 0.8 (max 0.2 (* 1/4 score-mul (my score)))))))
- :width "auto")
- (<h2 :style
- (css-attrib
- :font-size ((format nil "~$em" (min 2.5 (max 1.2 (* 1.5 score-mul (my score)))))))
- (<a :href (my url-path) (my title)))
- (<p :class "time" "Posted " (friendly-age-string (my time)) " ago"
- (when (my comments)
- (with-ml-output ", last comment " (friendly-age-string (comment-time (first (my comments)))) " ago")))))
+ :style
+ (css-attrib
+ :max-width ((format nil "~$%" (* 100 (min 0.8 (max 0.2 (* 1/4 score-mul (my score)))))))
+ :width "auto")
+ (<h2 :style
+ (css-attrib
+ :font-size ((format nil "~$em" (min 2.5 (max 1.2 (* 1.5 score-mul (my score)))))))
+ (<a :href (my url-path) (my title)))
+ (<p :class "time" "Posted " (friendly-age-string (my time)) " ago"
+ (when (my comments)
+ (with-ml-output ", last comment " (friendly-age-string (comment-time (first (my comments)))) " ago")))))
(my-defun entry combined-title ()
(with-ml-output
@@ -167,9 +167,9 @@
(my-defun entry set-page ()
(with-site ((its site (my blog)))
(defpage-lambda (my url-path)
- (lambda()
- (webapp ((my combined-title))
- (output-object-to-ml me)))))
+ (lambda()
+ (webapp ((my combined-title))
+ (output-object-to-ml me)))))
(my set-channel))
(my-defun entry channel-id ()
@@ -185,18 +185,18 @@
(my-defun entry read-paragraphs-from-buffer (buffer)
(setf (my paragraphs)
- (split-into-paragraphs
- (match-replace-all buffer
- ("${static-base}" (byte-vector-cat (blog-static-base-url (my blog)) (my name)))))))
+ (split-into-paragraphs
+ (match-replace-all buffer
+ ("${static-base}" (byte-vector-cat (blog-static-base-url (my blog)) (my name)))))))
(defun parse-time (str)
- (match-bind
+ (match-bind
(macrolet ((int (name &optional (len 2))
- `(progn t (,name (unsigned-byte :max-length ,len) 0))))
+ `(progn t (,name (unsigned-byte :max-length ,len) 0))))
(int year 4)
(int month)
(int day)
- (:?
+ (:?
(int hour)
(int minute)
(:? (int second))))
@@ -218,27 +218,27 @@
(let ((entry (make-entry :blog blog :name name)))
(with-shorthand-accessor (my entry)
(let ((remaining (slurp-file (my filename))))
- (setf (my time) (file-write-date (my filename)))
- (loop for line =
- (match-bind (line #\Newline after)
- remaining
- (setf remaining after)
- line)
- until (if-match-bind ( (* (space)) (last)) line)
- do (when (if-match-bind "XXX" line)
- (format *debug-io* "Entry not ready (XXX): ~A~&" name)
- (return-from read-in-entry))
- do (match-bind ((* (space)) header ":" (* (space)) value)
- line
- (case-match-fold-ascii-case header
- (("expiry-time" "time") (setf value (parse-time value)))
- ("tags" (setf value (split-into-list-by-comma value))))
- (let ((sym (normally-capitalized-string-to-symbol header)))
- (cond ((slot-exists-p entry sym)
- (setf (slot-value entry sym)
- value))
- (t (warn "~A" (strcat "blog entry " name " has invalid header " sym " (" header ")")))))))
- (my read-paragraphs-from-buffer remaining))
+ (setf (my time) (file-write-date (my filename)))
+ (loop for line =
+ (match-bind (line #\Newline after)
+ remaining
+ (setf remaining after)
+ line)
+ until (if-match-bind ( (* (space)) (last)) line)
+ do (when (if-match-bind "XXX" line)
+ (format *debug-io* "Entry not ready (XXX): ~A~&" name)
+ (return-from read-in-entry))
+ do (match-bind ((* (space)) header ":" (* (space)) value)
+ line
+ (case-match-fold-ascii-case header
+ (("expiry-time" "time") (setf value (parse-time value)))
+ ("tags" (setf value (split-into-list-by-comma value))))
+ (let ((sym (normally-capitalized-string-to-symbol header)))
+ (cond ((slot-exists-p entry sym)
+ (setf (slot-value entry sym)
+ value))
+ (t (warn "~A" (strcat "blog entry " name " has invalid header " sym " (" header ")")))))))
+ (my read-paragraphs-from-buffer remaining))
(my set-page))
entry))
View
62 src/blog/feed.lisp
@@ -2,44 +2,44 @@
(my-defun blog atom-feed (&key (count 10) tags)
(values
- (with-ml-output-start
+ (with-ml-output-start
(output-raw-ml "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
(tpd2.ml.atom:<feed :xmlns "http://www.w3.org/2005/Atom"
- (tpd2.ml.atom:<title
- (my name))
- (tpd2.ml.atom:<link
- :href (my link-base))
- (tpd2.ml.atom:<updated
- (w3c-timestring (my last-updated)))
- (loop repeat count
- for entry in (my ready-entries :tags tags) do
- (tpd2.ml.atom:<entry
- (tpd2.ml.atom:<title (entry-title entry))
- (tpd2.ml.atom:<updated (w3c-timestring (entry-time entry)))
- (tpd2.ml.atom:<id (entry-url-path entry))
- (tpd2.ml.atom:<link :href (entry-url-path entry))
- (tpd2.ml.atom:<content :type "html"
- (tpd2.io:sendbuf-to-byte-vector (entry-story-ml entry)))))))
+ (tpd2.ml.atom:<title
+ (my name))
+ (tpd2.ml.atom:<link
+ :href (my link-base))
+ (tpd2.ml.atom:<updated
+ (w3c-timestring (my last-updated)))
+ (loop repeat count
+ for entry in (my ready-entries :tags tags) do
+ (tpd2.ml.atom:<entry
+ (tpd2.ml.atom:<title (entry-title entry))
+ (tpd2.ml.atom:<updated (w3c-timestring (entry-time entry)))
+ (tpd2.ml.atom:<id (entry-url-path entry))
+ (tpd2.ml.atom:<link :href (entry-url-path entry))
+ (tpd2.ml.atom:<content :type "html"
+ (tpd2.io:sendbuf-to-byte-vector (entry-story-ml entry)))))))
(byte-vector-cat "Content-Type: application/atom+xml" tpd2.io:+newline+)))
(my-defun blog rss-feed (&key (count 10) tags)
(values
- (with-ml-output-start
+ (with-ml-output-start
(output-raw-ml "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
(tpd2.ml.rss:<rss :version "2.0"
- (tpd2.ml.rss:<channel
- (tpd2.ml.rss:<description
- (my name))
- (tpd2.ml.rss:<title
- (my name))
- (tpd2.ml.rss:<link
- (my link-base))
- (loop repeat count
- for entry in (my ready-entries :tags tags) do
- (tpd2.ml.rss:<item
- (tpd2.ml.rss:<title (entry-title entry))
- (tpd2.ml.rss:<link (entry-url-path entry))
- (tpd2.ml.rss:<description
- (tpd2.io:sendbuf-to-byte-vector (entry-story-ml entry))))))))
+ (tpd2.ml.rss:<channel
+ (tpd2.ml.rss:<description
+ (my name))
+ (tpd2.ml.rss:<title
+ (my name))
+ (tpd2.ml.rss:<link
+ (my link-base))
+ (loop repeat count
+ for entry in (my ready-entries :tags tags) do
+ (tpd2.ml.rss:<item
+ (tpd2.ml.rss:<title (entry-title entry))
+ (tpd2.ml.rss:<link (entry-url-path entry))
+ (tpd2.ml.rss:<description
+ (tpd2.io:sendbuf-to-byte-vector (entry-story-ml entry))))))))
(byte-vector-cat "Content-Type: application/rss+xml" tpd2.io:+newline+)))
View
216 src/datastore/datastore.lisp
@@ -8,8 +8,8 @@
(with-open-file (stream file :if-does-not-exist nil)
(when stream
(loop for form = (read stream nil 'eof)
- until (eq form 'eof)
- do (eval form)))))
+ until (eq form 'eof)
+ do (eval form)))))
(defun datastore-open-p ()
(and (boundp '*datastore*) *datastore*))
@@ -86,8 +86,8 @@
`(utf8-encode ,(force-string array)))
(t
`(make-array ',(array-dimensions array)
- :element-type ',(array-element-type array)
- :initial-contents (list ,@(map 'list 'datastore-save-form array))))))
+ :element-type ',(array-element-type array)
+ :initial-contents (list ,@(map 'list 'datastore-save-form array))))))
(defmethod datastore-save-form ((list list))
(when list
`(list ,@(map 'list 'datastore-save-form list))))
@@ -96,112 +96,112 @@
(defmacro defrecord (name &rest original-slot-defs)
(labels ((slot-name (slot-def)
- (if (listp slot-def) (first slot-def) slot-def))
- (slot-plist (slot-def)
- (when (listp slot-def) (cdr slot-def)))
- (slot-prop (slot-def prop)
- (getf (slot-plist slot-def) prop))
- (slot-transient (slot-def)
- (slot-prop slot-def :transient))
- (slot-persistent (slot-def)
- (not (slot-transient slot-def)))
- (slot-indexed (slot-def)
- (slot-prop slot-def :index))
- (defstruct-slot-def (slot-def)
- (let ((ret (copy-list (slot-plist slot-def)))
- (initform nil))
- (dolist (option '(:transient :index :initform))
- (remf ret option))
- (list* (slot-name slot-def) initform ret)))
- (guarded-slot-accessor (slot-name)
- (concat-sym name '- slot-name))
- (real-slot-accessor (slot-name)
- (concat-sym-from-sym-package name 'unlogged- name '- slot-name))
- (real-constructor ()
- (concat-sym-from-sym-package name 'unlogged-make- name))
- (guarded-constructor ()
- (concat-sym-from-sym-package name 'make- name))
- (slot-index (slot-def)
- (let ((slot-name (slot-name slot-def)))
- `(get ',name ',(concat-sym name '-%datastore-index- slot-name)))))
+ (if (listp slot-def) (first slot-def) slot-def))
+ (slot-plist (slot-def)
+ (when (listp slot-def) (cdr slot-def)))
+ (slot-prop (slot-def prop)
+ (getf (slot-plist slot-def) prop))
+ (slot-transient (slot-def)
+ (slot-prop slot-def :transient))
+ (slot-persistent (slot-def)
+ (not (slot-transient slot-def)))
+ (slot-indexed (slot-def)
+ (slot-prop slot-def :index))
+ (defstruct-slot-def (slot-def)
+ (let ((ret (copy-list (slot-plist slot-def)))
+ (initform nil))
+ (dolist (option '(:transient :index :initform))
+ (remf ret option))
+ (list* (slot-name slot-def) initform ret)))
+ (guarded-slot-accessor (slot-name)
+ (concat-sym name '- slot-name))
+ (real-slot-accessor (slot-name)
+ (concat-sym-from-sym-package name 'unlogged- name '- slot-name))
+ (real-constructor ()
+ (concat-sym-from-sym-package name 'unlogged-make- name))
+ (guarded-constructor ()
+ (concat-sym-from-sym-package name 'make- name))
+ (slot-index (slot-def)
+ (let ((slot-name (slot-name slot-def)))
+ `(get ',name ',(concat-sym name '-%datastore-index- slot-name)))))
(let* ((slot-defs (list* '(datastore-id :transient t :index t :initform (datastore-id-next)) original-slot-defs))
- (indexed-slots (filter #'slot-indexed slot-defs))
- (defstruct-slot-defs (mapcar #'defstruct-slot-def slot-defs))
- (persistent? (some #'slot-persistent slot-defs)))
+ (indexed-slots (filter #'slot-indexed slot-defs))
+ (defstruct-slot-defs (mapcar #'defstruct-slot-def slot-defs))
+ (persistent? (some #'slot-persistent slot-defs)))
(with-unique-names (constructed-object)
- `(progn
- (defstruct (,name
- (:constructor ,(real-constructor))
- (:conc-name ,(concat-sym-from-sym-package name 'unlogged- name '-)))
- ,@defstruct-slot-defs)
-
- ;;; Constructor
-
- (defun ,(guarded-constructor)
- (&key ,@(loop for slot-def in slot-defs
- collect `(,(slot-name slot-def) ,(slot-prop slot-def :initform))))
- (let ((,constructed-object (,(real-constructor))))
- (datastore-id-register datastore-id)
- ,(when persistent?
- `(datastore-log `(,',(guarded-constructor) :datastore-id ,datastore-id)))
- ,@(loop for slot-def in slot-defs
- for slot-name = (slot-name slot-def)
- collect `(setf (,(guarded-slot-accessor slot-name) ,constructed-object) ,slot-name))
-
- ,constructed-object))
-
- ,@(loop for slot-def in indexed-slots
- collect `(unless ,(slot-index slot-def)
- (setf ,(slot-index slot-def) (make-datastore-index :slot-name ',(slot-name slot-def)))))
-
- ;;; Guarded accessors
-
- ,@(loop for slot-def in slot-defs
- for slot-name = (slot-name slot-def)
- collect
- `(defun ,(guarded-slot-accessor slot-name) (,name)
- (,(real-slot-accessor slot-name) ,name))
- collect
- `(defun (setf ,(guarded-slot-accessor slot-name)) (new-value ,name)
- ,(when (slot-indexed slot-def)
- `(datastore-index-del ,(slot-index slot-def) ,name))
- (multiple-value-prog1
- (setf (,(real-slot-accessor slot-name) ,name) new-value)
- ,(when (slot-indexed slot-def)
- `(datastore-index-add ,(slot-index slot-def) ,name))
- ,(when (slot-persistent slot-def)
- `(datastore-log
- `(setf (,',(guarded-slot-accessor slot-name) ,(datastore-ref-form ,name)) ,(datastore-save-form new-value)))))))
-
- (defmethod datastore-delete ((object ,name))
- ,(when persistent?
- `(when (slot-value object 'datastore-id)
- (datastore-log `(datastore-delete ,(datastore-ref-form object)))))
- ,@(loop for slot-def in indexed-slots collect
- `(datastore-index-del ,(slot-index slot-def) object))
- (setf (slot-value object 'datastore-id) nil))
- (defmethod datastore-retrieve-all ((class (eql ',name)) &optional max-returned)
- (let ((i 0))
- (loop for v being the hash-values of (datastore-index-table ,(slot-index 'datastore-id))
- until (and max-returned (>= i max-returned))
- do (incf i (length v))
- append v)))
-
- (defmethod datastore-record-constructor-form ((object ,name))
- (list ',(guarded-constructor)
- ,@(loop for slot-def in slot-defs
- for slot-name = (slot-name slot-def)
- unless (eq 'datastore-id slot-name)
- collect (intern (symbol-name slot-name) :keyword)
- and
- collect `(datastore-save-form (,(real-slot-accessor slot-name) object)))))
-
-
- ,@(loop for slot-def in indexed-slots collect
- `(defmethod datastore-retrieve-indexed ((class (eql ',name)) (index (eql ',(slot-name slot-def))) value)
- (datastore-index-get ,(slot-index slot-def) value)))
-
- ',name)))))
+ `(progn
+ (defstruct (,name
+ (:constructor ,(real-constructor))
+ (:conc-name ,(concat-sym-from-sym-package name 'unlogged- name '-)))
+ ,@defstruct-slot-defs)
+
+ ;;; Constructor
+
+ (defun ,(guarded-constructor)
+ (&key ,@(loop for slot-def in slot-defs
+ collect `(,(slot-name slot-def) ,(slot-prop slot-def :initform))))
+ (let ((,constructed-object (,(real-constructor))))
+ (datastore-id-register datastore-id)
+ ,(when persistent?
+ `(datastore-log `(,',(guarded-constructor) :datastore-id ,datastore-id)))
+ ,@(loop for slot-def in slot-defs
+ for slot-name = (slot-name slot-def)
+ collect `(setf (,(guarded-slot-accessor slot-name) ,constructed-object) ,slot-name))
+
+ ,constructed-object))
+
+ ,@(loop for slot-def in indexed-slots
+ collect `(unless ,(slot-index slot-def)
+ (setf ,(slot-index slot-def) (make-datastore-index :slot-name ',(slot-name slot-def)))))
+
+ ;;; Guarded accessors
+
+ ,@(loop for slot-def in slot-defs
+ for slot-name = (slot-name slot-def)
+ collect
+ `(defun ,(guarded-slot-accessor slot-name) (,name)
+ (,(real-slot-accessor slot-name) ,name))
+ collect
+ `(defun (setf ,(guarded-slot-accessor slot-name)) (new-value ,name)
+ ,(when (slot-indexed slot-def)
+ `(datastore-index-del ,(slot-index slot-def) ,name))
+ (multiple-value-prog1
+ (setf (,(real-slot-accessor slot-name) ,name) new-value)
+ ,(when (slot-indexed slot-def)
+ `(datastore-index-add ,(slot-index slot-def) ,name))
+ ,(when (slot-persistent slot-def)
+ `(datastore-log
+ `(setf (,',(guarded-slot-accessor slot-name) ,(datastore-ref-form ,name)) ,(datastore-save-form new-value)))))))
+
+ (defmethod datastore-delete ((object ,name))
+ ,(when persistent?
+ `(when (slot-value object 'datastore-id)
+ (datastore-log `(datastore-delete ,(datastore-ref-form object)))))
+ ,@(loop for slot-def in indexed-slots collect
+ `(datastore-index-del ,(slot-index slot-def) object))
+ (setf (slot-value object 'datastore-id) nil))
+ (defmethod datastore-retrieve-all ((class (eql ',name)) &optional max-returned)
+ (let ((i 0))
+ (loop for v being the hash-values of (datastore-index-table ,(slot-index 'datastore-id))
+ until (and max-returned (>= i max-returned))
+ do (incf i (length v))
+ append v)))
+
+ (defmethod datastore-record-constructor-form ((object ,name))
+ (list ',(guarded-constructor)
+ ,@(loop for slot-def in slot-defs
+ for slot-name = (slot-name slot-def)
+ unless (eq 'datastore-id slot-name)
+ collect (intern (symbol-name slot-name) :keyword)
+ and
+ collect `(datastore-save-form (,(real-slot-accessor slot-name) object)))))
+
+
+ ,@(loop for slot-def in indexed-slots collect
+ `(defmethod datastore-retrieve-indexed ((class (eql ',name)) (index (eql ',(slot-name slot-def))) value)
+ (datastore-index-get ,(slot-index slot-def) value)))
+
+ ',name)))))
View
22 src/game/card.lisp
@@ -4,7 +4,7 @@
(define-constant +suits+ '(:clubs :hearts :spades :diamonds) :test 'equal)
(defconstant +cards-per-suit+ 13))
-(defstruct card
+(defstruct card
(suit :clubs :type #.`(member ,@+suits+))
(value 0 :type (integer 0 #.+cards-per-suit+)))
@@ -18,15 +18,15 @@
(my-defun card name ()
(format nil "~A of ~A"
- (my value-string)
- (string-capitalize (symbol-name (my suit)))))
+ (my value-string)
+ (string-capitalize (symbol-name (my suit)))))
(my-defun card number ()
(+ (* (position (my suit) +suits+) +cards-per-suit+) (my value)))
(defun make-card-from-number (number)
(multiple-value-bind
- (s-n v)
+ (s-n v)
(floor number +cards-per-suit+)
(make-card :suit (elt +suits+ s-n) :value v)))
@@ -34,10 +34,10 @@
(<span
:class "card"
(<span :class (symbol-name (my suit))
- (my value-string)
- (output-raw-ml
- "&")
- (case (my suit)
- (:diamonds "diams")
- (t (string-downcase (symbol-name (my suit)))))
- ";")))
+ (my value-string)
+ (output-raw-ml
+ "&")
+ (case (my suit)
+ (:diamonds "diams")
+ (t (string-downcase (symbol-name (my suit)))))
+ ";")))
View
42 src/game/coins.lisp
@@ -7,38 +7,38 @@
(:unplayable t))
(my-defun coin-game finished :before (&rest args)
- (declare (ignorable args))
- (loop for p in (my players)
- do
- (setf (player-controller-var p 'coins) (its coins p))))
+ (declare (ignorable args))
+ (loop for p in (my players)
+ do
+ (setf (player-controller-var p 'coins) (its coins p))))
(my-defun coin-game-player 'object-to-ml ()
(<div :class "coin-game-player"
- (call-next-method)
- (let ((coins (or (my coins) (my 'player-controller-var 'coins))))
- (when coins
- (if (plusp coins)
- (<p (format nil "~D coin~:P" coins))
- (<p :class "bankrupt" "No coins"))))))
+ (call-next-method)
+ (let ((coins (or (my coins) (my 'player-controller-var 'coins))))
+ (when coins
+ (if (plusp coins)
+ (<p (format nil "~D coin~:P" coins))
+ (<p :class "bankrupt" "No coins"))))))
(my-defun coin-game 'object-to-ml :around ()
(<div :class "coin-game"
- (call-next-method)
- (let ((coins (webapp-frame-var 'coins)))
- (cond (
- (and coins (plusp coins))
- (<h3 (format nil "You have ~D coin~:P." coins)))
- (t
- (<h3 :class "bankrupt" "You have no coins."))))))
+ (call-next-method)
+ (let ((coins (webapp-frame-var 'coins)))
+ (cond (
+ (and coins (plusp coins))
+ (<h3 (format nil "You have ~D coin~:P." coins)))
+ (t
+ (<h3 :class "bankrupt" "You have no coins."))))))
(my-defun coin-game setup-coins ()
(loop for p in (my players)
- do (setf (its coins p)
- (setf (player-controller-var p 'coins)
- (max-nil-ok 0 (its coins p) (player-controller-var p 'coins))))))
+ do (setf (its coins p)
+ (setf (player-controller-var p 'coins)
+ (max-nil-ok 0 (its coins p) (player-controller-var p 'coins))))))
(my-defun coin-game players-ready :after ()
- (my setup-coins))
+ (my setup-coins))
(my-defun coin-game-player give-coins (amount)
(incf (my coins) amount)
View
8 src/game/controllers.lisp
@@ -20,9 +20,9 @@
(defmethod move ((stream stream) player-state move-type choices &rest args)
(format stream "Details ~{~A ~}~&Game state ~A~&Your state ~A~&Your choices for ~A are ~A:~&" args (player-game player-state)
- player-state
- move-type choices)
+ player-state
+ move-type choices)
(loop do
- (handler-case (return-from move (validate-choice choices (read-safely stream)))
- (error (e) (format t "Sorry that move is not allowed; ~A~&" e)))))
+ (handler-case (return-from move (validate-choice choices (read-safely stream)))
+ (error (e) (format t "Sorry that move is not allowed; ~A~&" e)))))
View
132 src/game/framework.lisp
@@ -18,11 +18,11 @@
(defun validate-choice (choices choice)
(acond ((and (not choice) (member nil (choices-list choices)))
- nil)
- ((and choice (find choice (choices-list choices) :test 'equalp))
- it)
- (t
- 'invalid-choice)))
+ nil)
+ ((and choice (find choice (choices-list choices) :test 'equalp))
+ it)
+ (t
+ 'invalid-choice)))
(defun random-choice (choices)
(random-elt (choices-list choices)))
@@ -45,7 +45,7 @@
(my-defun game announce (message &rest args)
(loop for l in (my listeners)
- do (apply 'inform l me message args)))
+ do (apply 'inform l me message args)))
(defstruct game-generator
make-game
@@ -58,61 +58,61 @@
(my name))
(eval-always (defvar *games* (make-hash-table :test 'equalp)))
-
+
(defmacro defgame (name superclasses slots defplayer &rest options)
(let ((options (copy-list options)))
(flet ((opt (name &optional default)
- (prog1 (second (or (assoc name options) (list nil default)))
- (deletef name options :key 'car))))
+ (prog1 (second (or (assoc name options) (list nil default)))
+ (deletef name options :key 'car))))
(let* (
- (game-name-string (force-byte-vector (or (opt :game-name) (string-capitalize (symbol-name name)))))
- (game-description (opt :game-description))
- (playable (not (opt :unplayable))) ; for abstract base classes
- (advertised (opt :advertised playable)))
+ (game-name-string (force-byte-vector (or (opt :game-name) (string-capitalize (symbol-name name)))))
+ (game-description (opt :game-description))
+ (playable (not (opt :unplayable))) ; for abstract base classes
+ (advertised (opt :advertised playable)))
(flet ((defgameclass-form (name superclasses options slots)
- `(defmyclass (,name
- ,@(mapcar (lambda(c) `(:include ,c))
- superclasses)
- ,@options)
- ,@slots)))
- (destructuring-bind
- (defplayer-sym df-superclasses df-slots &rest df-options)
- defplayer
- (assert (eq 'defplayer defplayer-sym))
- `(eval-always
- ,(when playable
- `(setf (gethash ,game-name-string *games*)
- (make-game-generator
- :name ,game-name-string
- :description ,(when game-description `(tpd2.io:sendbuf-to-byte-vector (with-ml-output ,game-description)))
- :advertised ,advertised
- :make-game (lambda(controllers)
- (let ((game (,(concat-sym-from-sym-package name 'make- name))))
- (let ((players
- (mapcar (lambda(c)
- (,(concat-sym-from-sym-package name 'make- name '-player)
- :game game
- :controller c)) controllers)))
- (setf (game-players game) players))
- game)))))
- ,(defgameclass-form (concat-sym name '-player)
- `(,@df-superclasses
- ,@(loop for s in superclasses collect
- (concat-sym s '-player))
- player)
- df-options
- df-slots)
- ,(defgameclass-form name
- (or superclasses (list 'game))
- options
- slots)
- (defmethod game-name ((,name ,name))
- ,game-name-string)
-
- ,@(when playable
- `((eval-when (:load-toplevel :execute)
- (web-add-game (find-game-generator ,game-name-string)
- ,(force-byte-vector (string-downcase (force-string name))))))))))))))
+ `(defmyclass (,name
+ ,@(mapcar (lambda(c) `(:include ,c))
+ superclasses)
+ ,@options)
+ ,@slots)))
+ (destructuring-bind
+ (defplayer-sym df-superclasses df-slots &rest df-options)
+ defplayer
+ (assert (eq 'defplayer defplayer-sym))
+ `(eval-always
+ ,(when playable
+ `(setf (gethash ,game-name-string *games*)
+ (make-game-generator
+ :name ,game-name-string
+ :description ,(when game-description `(tpd2.io:sendbuf-to-byte-vector (with-ml-output ,game-description)))
+ :advertised ,advertised
+ :make-game (lambda(controllers)
+ (let ((game (,(concat-sym-from-sym-package name 'make- name))))
+ (let ((players
+ (mapcar (lambda(c)
+ (,(concat-sym-from-sym-package name 'make- name '-player)
+ :game game
+ :controller c)) controllers)))
+ (setf (game-players game) players))
+ game)))))
+ ,(defgameclass-form (concat-sym name '-player)
+ `(,@df-superclasses
+ ,@(loop for s in superclasses collect
+ (concat-sym s '-player))
+ player)
+ df-options
+ df-slots)
+ ,(defgameclass-form name
+ (or superclasses (list 'game))
+ options
+ slots)
+ (defmethod game-name ((,name ,name))
+ ,game-name-string)
+
+ ,@(when playable
+ `((eval-when (:load-toplevel :execute)
+ (web-add-game (find-game-generator ,game-name-string)
+ ,(force-byte-vector (string-downcase (force-string name))))))))))))))
(my-defun game generator ()
(gethash (my name) *games*))
@@ -122,18 +122,18 @@
(defrules game secret-move (type player choices &rest args)
(check-type type keyword)
- (let ((ret (call/cc
- (lambda(cc)
- (apply 'move-continuation
- (lambda(&rest a)
- (unless (my game-over)
- (apply cc a)))
- (player-controller player) player type choices
- args)
- 'with-call/cc))))
+ (let ((ret (call/cc
+ (lambda(cc)
+ (apply 'move-continuation
+ (lambda(&rest a)
+ (unless (my game-over)
+ (apply cc a)))
+ (player-controller player) player type choices
+ args)
+ 'with-call/cc))))
(let ((vc (validate-choice choices ret)))
(when (eq vc 'invalid-choice)
- (error "invalid choice picked ~A from ~A" ret choices))
+ (error "invalid choice picked ~A from ~A" ret choices))
vc)))
(defrules game move (type player choices &rest args)
View
4 src/game/generic.lisp
@@ -22,10 +22,10 @@
(defmethod choices-list-form ((first (eql :integer)) &rest args)
(destructuring-bind
- (min-inclusive max-inclusive)
+ (min-inclusive max-inclusive)
args
(loop for i from min-inclusive upto max-inclusive
- collect i)))
+ collect i)))
(defmethod choices-list-form ((first (eql :one)) &rest args)
args)
View
26 src/game/unassigned-controller.lisp
@@ -18,9 +18,9 @@
(my-defun unassigned-controller 'player-controller-name-to-ml ()
; (strcat "Unassigned (" (timeout-remaining (my timeout)) " seconds left)")
- (<span :class "unassigned-player"
- (html-action-link "Unassigned"
- (my assign-robot))))
+ (<span :class "unassigned-player"
+ (html-action-link "Unassigned"
+ (my assign-robot))))
(my-defun unassigned-controller player-state ()
(find me (game-players (my game)) :key 'player-controller))
@@ -37,7 +37,7 @@
(game-announce (my game) :new-player :player player-state))
(setf (my game) nil)
(loop for i in (reverse (my move-states)) do
- (move-state-continue i other))))
+ (move-state-continue i other))))
(my-defun unassigned-controller assign-robot ()
(my assign (random-elt *bots*)))
@@ -47,10 +47,10 @@
(defmethod move-continuation (k (controller unassigned-controller) player-state move-type choices &rest args)
(push (make-move-state :cc k :move-type move-type :player-state player-state :choices choices :args args)
- (unassigned-controller-move-states controller)))
+ (unassigned-controller-move-states controller)))
(my-defun game-generator join-or-start (controller)
- (acond
+ (acond
((pop (my unassigned-controllers-waiting))
(let ((game (unassigned-controller-game it)))
(unassigned-controller-assign it controller)
@@ -58,14 +58,14 @@
(t
(let ((uc (make-unassigned-controller :game-generator me)))
(let ((game (funcall (my make-game) (list uc controller))))
- (setf (unassigned-controller-game uc) game)
+ (setf (unassigned-controller-game uc) game)
- (setf (unassigned-controller-timeout uc)
- (make-timeout :delay 5
- :func (lambda()(unassigned-controller-assign-robot uc))))
- (appendf (my unassigned-controllers-waiting) (list uc))
- (play game)
- game)))))
+ (setf (unassigned-controller-timeout uc)
+ (make-timeout :delay 5
+ :func (lambda()(unassigned-controller-assign-robot uc))))
+ (appendf (my unassigned-controllers-waiting) (list uc))
+ (play game)
+ game)))))
(my-defun unassigned-controller 'inform (game-state (message (eql :game-over)) &rest args)
View
92 src/game/web-messages.lisp
@@ -4,74 +4,74 @@
`(my-defun web-state 'inform (game-state (message (eql ,message)) &key ,@args &allow-other-keys)
(declare (ignorable game-state))
(macrolet ((a (&rest args)
- `(my add-announcement (<p :class "game-message" ,@args))))
+ `(my add-announcement (<p :class "game-message" ,@args))))
,@body)))
(macrolet ((messages (&body body)
- `(progn
- ,@(loop for (keyword args . ml) in body
- collect `(def-web-state-message ,keyword ,args
- (a ,@ml))))))
+ `(progn
+ ,@(loop for (keyword args . ml) in body
+ collect `(def-web-state-message ,keyword ,args
+ (a ,@ml))))))
- (messages
+ (messages
(:talk (sender text)
- (<span :class "game-talk-message" sender ": " (<q text)))
+ (<span :class "game-talk-message" sender ": " (<q text)))
(:new-player (player)
- player " has joined the game.")
+ player " has joined the game.")
(:resigned (player)
- player " has resigned.")
+ player " has resigned.")
(:timed-out (player)
- player " has timed-out.")
+ player " has timed-out.")
(:select-card (player choice)
- player " played " (output-object-to-ml (make-card-from-number choice)) ".")
+ player " played " (output-object-to-ml (make-card-from-number choice)) ".")
(:select-demand (player choice)
- player " demanded " choice ".")
+ player " demanded " choice ".")
(:select (player choice)
- player " chose " (friendly-string choice) ".")
+ player " chose " (friendly-string choice) ".")
(:reject-cards (player choice)
- player
- (if choice
- " wants to change cards."
- " is satisfied with the cards."))
+ player
+ (if choice
+ " wants to change cards."
+ " is satisfied with the cards."))
(:accept-new-stake (player choice)
- player
- (if choice
- " saw the raise."
- " folded."))
+ player
+ (if choice
+ " saw the raise."
+ " folded."))
(:select-new-stake (player choice)
- player
- " raised to "
- choice
- ".")
+ player
+ " raised to "
+ choice
+ ".")
(:winner (player coins)
- player " won"
- (when coins
- (with-ml-output " " coins " coins"))
- "."
- )
+ player " won"
+ (when coins
+ (with-ml-output " " coins " coins"))
+ "."
+ )
(:game-over (winner result)
- (cond (winner
- (with-ml-output
- winner " won the game.")
- )
- (t
- (when result
- (with-ml-output
- (friendly-string result) ".")
- "Game over."))))
+ (cond (winner
+ (with-ml-output
+ winner " won the game.")
+ )
+ (t
+ (when result
+ (with-ml-output
+ (friendly-string result) ".")
+ "Game over."))))
(:demand (player amount)
- player " demanded " amount ".")
+ player " demanded " amount ".")
(:profit (player amount)
- player
- (if (minusp amount) " lost " " gained ")
- (abs amount) ".")
+ player
+ (if (minusp amount) " lost " " gained ")
+ (abs amount) ".")
(:bankrupt (player)
- player " went bankrupt.")
+ player " went bankrupt.")
(:betrayal (player)
- player " betrayed everybody else.")
+ player " betrayed everybody else.")
(:new-state ()
- "New game.")))
+ "New game.")))
View
364 src/game/web.lisp
@@ -19,8 +19,8 @@
(let ((frame (webapp-frame)))
(check-type frame frame)
(let ((w (make-web-state :frame frame)))
- (push (lambda (f) (declare (ignore f)) (channel-destroy w))
- (frame-destroy-hooks frame))
+ (push (lambda (f) (declare (ignore f)) (channel-destroy w))
+ (frame-destroy-hooks frame))
w)))
(my-defun web-state 'inform :after (game-state (message (eql :new-state)) &rest args)
@@ -29,25 +29,25 @@
(my-defun web-state 'inform (game-state message &rest args)
(declare (ignore game-state))
- (my add-announcement
+ (my add-announcement
(<p :class "game-message"
- message
- " "
- (output-object-to-ml args))))
+ message
+ " "
+ (output-object-to-ml args))))
(my-defun web-state resigned ()
(not (loop for p in (game-players (my game-state)) thereis (eql me (player-controller p)))))
(my-defun web-state 'inform :before (game-state message &rest args)
- (declare (ignore args message))
-
- (setf (my game-state) game-state
+ (declare (ignore args message))
- (timeout-func (my timeout))
- (lambda ()
- (unless (game-game-over (my game-state))
- (setf (my timed-out) t)
- (my resign :reason :timed-out)))))
+ (setf (my game-state) game-state
+
+ (timeout-func (my timeout))
+ (lambda ()
+ (unless (game-game-over (my game-state))
+ (setf (my timed-out) t)
+ (my resign :reason :timed-out)))))
(my-defun web-state add-announcement (a)
(appendf (my announcements) (list a))
@@ -56,15 +56,15 @@
(defmethod move-continuation (k (controller web-state) player-state move-type choices &rest args)
(web-state-add-move-state controller
(make-move-state :cc k
- :move-type move-type
- :player-state player-state
- :choices choices
- :args args)))
+ :move-type move-type
+ :player-state player-state
+ :choices choices
+ :args args)))
-(defmethod move-continuation (k (controller web-state)
- player-state
- (move-type (eql :ready-to-play)) choices &rest args)
+(defmethod move-continuation (k (controller web-state)
+ player-state
+ (move-type (eql :ready-to-play)) choices &rest args)
(declare (ignore args player-state choices))
(funcall k t))
@@ -77,7 +77,7 @@
(my-defun web-state add-move-state (move-state)
(my timeout-reset)
(appendf (my waiting-for-input)
- (list move-state))
+ (list move-state))
(my try-to-move)
(my notify))
@@ -86,24 +86,24 @@
(my-defun web-state queue-choice (move-type choice)
(appendf (my queued-choices)
- (list (make-queued-choice :move-type move-type :choice choice)))
+ (list (make-queued-choice :move-type move-type :choice choice)))
(my try-to-move)
(values))
(my-defun web-state try-to-move ()
(loop for waiting in (my waiting-for-input) do
- (loop for qc in (my queued-choices)
- do
- (when (eql (queued-choice-move-type qc) (move-state-move-type waiting))
- (deletef qc (my queued-choices))
- (unless (eq 'invalid-choice (validate-choice (move-state-choices waiting) (queued-choice-choice qc)))
- (deletef waiting (my waiting-for-input))
- (if (my waiting-for-input)
- (my timeout-reset)
- (my timeout-cancel))
- (funcall (move-state-cc waiting) (queued-choice-choice qc))
- (my notify)
- (return-from web-state-try-to-move))))))
+ (loop for qc in (my queued-choices)
+ do
+ (when (eql (queued-choice-move-type qc) (move-state-move-type waiting))
+ (deletef qc (my queued-choices))
+ (unless (eq 'invalid-choice (validate-choice (move-state-choices waiting) (queued-choice-choice qc)))
+ (deletef waiting (my waiting-for-input))
+ (if (my waiting-for-input)
+ (my timeout-reset)
+ (my timeout-cancel))
+ (funcall (move-state-cc waiting) (queued-choice-choice qc))
+ (my notify)
+ (return-from web-state-try-to-move))))))
(defun keyword-to-friendly-string (keyword)
@@ -118,56 +118,56 @@
(my-defun move-state 'object-to-ml ()
(<div :class "move-state"
- (let ((friendly-move-type (keyword-to-friendly-string (my move-type))))
- (cond ((eq :boolean (my choices))
- (<p
- (loop for (keyword value) on (my args) by #'cddr
- do (with-ml-output "The " (string-downcase (keyword-to-friendly-string keyword)) " is " value ". "))
-
- friendly-move-type
- "? "
-
- (html-action-link "Yes" (my queue-choice t) (values))
- " "
- (html-action-link "No" (my queue-choice nil) (values))))
- ((eql :select-card (my move-type))
- (<p friendly-move-type "."))
- (t
- (<p friendly-move-type
- (cond ((eql (force-first (my choices)) :integer)
- (with-ml-output " from " (reduce #'min (choices-list (my choices))) " to "
- (reduce #'max (choices-list (my choices))) ". "))
- (t
- (with-ml-output (format nil " ~{~A ~}" (my args)) " from ")))
-
- (loop for c in (choices-list (my choices)) do
- (let-current-values (c)
- (with-ml-output " "
- (html-action-link (friendly-string c)
- (my queue-choice c)))))
-
- (html-action-form
- ""
- (choice)
- (my queue-choice (read-safely-from-string choice))
- (values))))))))
+ (let ((friendly-move-type (keyword-to-friendly-string (my move-type))))
+ (cond ((eq :boolean (my choices))
+ (<p
+ (loop for (keyword value) on (my args) by #'cddr
+ do (with-ml-output "The " (string-downcase (keyword-to-friendly-string keyword)) " is " value ". "))
+
+ friendly-move-type
+ "? "
+
+ (html-action-link "Yes" (my queue-choice t) (values))
+ " "
+ (html-action-link "No" (my queue-choice nil) (values))))
+ ((eql :select-card (my move-type))
+ (<p friendly-move-type "."))
+ (t
+ (<p friendly-move-type
+ (cond ((eql (force-first (my choices)) :integer)
+ (with-ml-output " from " (reduce #'min (choices-list (my choices))) " to "
+ (reduce #'max (choices-list (my choices))) ". "))
+ (t
+ (with-ml-output (format nil " ~{~A ~}" (my args)) " from ")))
+
+ (loop for c in (choices-list (my choices)) do
+ (let-current-values (c)
+ (with-ml-output " "
+ (html-action-link (friendly-string c)
+ (my queue-choice c)))))
+
+ (html-action-form
+ ""
+ (choice)
+ (my queue-choice (read-safely-from-string choice))
+ (values))))))))
(my-defun game 'object-to-ml ()
(<div :class "players"
- (loop for p in (my players)
- for once = t then nil
- unless once do (<div :class "separate")
- do (with-ml-output
- (player-state-to-ml p)))
- (<div :style (css-attrib :clear "both" :float "none" :border "none"))))
+ (loop for p in (my players)
+ for once = t then nil
+ unless once do (<div :class "separate")
+ do (with-ml-output
+ (player-state-to-ml p)))
+ (<div :style (css-attrib :clear "both" :float "none" :border "none"))))
(my-defun game 'object-to-ml :around ()
- (if (my game-over)
- (<h2 "Game over." (my play-again-ml) "?")
- (call-next-method)))
+ (if (my game-over)
+ (<h2 "Game over." (my play-again-ml) "?")
+ (call-next-method)))
(defun current-web-controller (controller)
(and (web-state-p controller)
@@ -190,22 +190,22 @@
(defgeneric game-title-ml (game)
(:method (game)
(<h2 :class "game-title"
- (game-name game))))
+ (game-name game))))
(my-defun web-state 'object-to-ml ()
(assert (my game-state) () "No game started; please use game-new-state")
- (<div :class "game-state"
- (<div :class "game-header"
- (game-title-ml (my game-state)))
-
- (call-next-method)
-
- (<div :class "talk"
- (html-action-form "Talk "
- ((text nil :reset ""))
- (without-ml-output
- (my timeout-reset)
- (game-talk (my game-state) me text))))))
+ (<div :class "game-state"
+ (<div :class "game-header"
+ (game-title-ml (my game-state)))
+
+ (call-next-method)
+
+ (<div :class "talk"
+ (html-action-form "Talk "
+ ((text nil :reset ""))
+ (without-ml-output
+ (my timeout-reset)
+ (game-talk (my game-state) me text))))))
(my-defun game play-again-ml ()
(html-replace-link "Play again"
@@ -215,69 +215,69 @@
(game-play-again-ml (my game-state)))
(my-defun web-state 'simple-channel-body-ml ()
- (<div :class "game-state"
- (<div :class "game-state-body"
- (<p :class "close-game"
- (cond ((game-game-over (my game-state))
- (my play-again-ml))
- (t
- (html-action-link "Resign"
- (my resign))))))
-
- (<div :class "messages-and-talk"
- (<div :class tpd2.webapp:+html-class-scroll-to-bottom+
- (output-object-to-ml (my announcements))))
-
- (cond
- ((my timed-out)
- (<p (load-time-value (format nil "Timed out; sorry, you took longer than ~R second~:P to respond."
- *web-state-move-timeout*))
- (my play-again-ml) "?"))
- ((my resigned)
- (<p "Resigned." (my play-again-ml)))
- (t
- (output-object-to-ml (my game-state))
-
- (when (my waiting-for-input)
- (<div :class "moves"
- (loop for m in (my waiting-for-input)
- do
- (output-object-to-ml m))))))))
+ (<div :class "game-state"
+ (<div :class "game-state-body"
+ (<p :class "close-game"
+ (cond ((game-game-over (my game-state))
+ (my play-again-ml))
+ (t
+ (html-action-link "Resign"
+ (my resign))))))
+
+ (<div :class "messages-and-talk"
+ (<div :class tpd2.webapp:+html-class-scroll-to-bottom+
+ (output-object-to-ml (my announcements))))
+
+ (cond
+ ((my timed-out)
+ (<p (load-time-value (format nil "Timed out; sorry, you took longer than ~R second~:P to respond."
+ *web-state-move-timeout*))
+ (my play-again-ml) "?"))
+ ((my resigned)
+ (<p "Resigned." (my play-again-ml)))
+ (t
+ (output-object-to-ml (my game-state))
+
+ (when (my waiting-for-input)
+ (<div :class "moves"
+ (loop for m in (my waiting-for-input)
+ do
+ (output-object-to-ml m))))))))
(my-defun player state-to-ml ()
(<div :class "player"
- (<h3 me
- (when (my waiting-for-input)
- (<span :class "turn" "'s turn")))))
+ (<h3 me
+ (when (my waiting-for-input)
+ (<span :class "turn" "'s turn")))))
(my-defun player 'object-to-ml ()
(player-controller-name-to-ml (my controller)))
(defun css ()
- (css-html-style
+ (css-html-style
((".inherit" <input <a)
:text-decoration "inherit" :color "inherit" :background-color "inherit" :font-size "inherit" :font-weight "inherit"
- :font-family "inherit"
+ :font-family "inherit"
:border "none" :padding "0 0 0 0" :margin "0 0 0 0")
(<body :font-family "georgia, serif" :word-spacing "0.075em" :letter-spacing "0.025em" :margin-left "5%" :margin-right "5%"
- :background-color "white")
+ :background-color "white")
((<h1 <h2 <h3 <h4 <h5 <h6) :letter-spacing "0.05em" :font-weight "normal" :margin "0 0 0 0" :padding "0 0 0 0")
((<span <div <h1 <h2 <h3 <h4 <h5 <h6 <p <a <input) :direction "ltr" :unicode-bidi "bidi-override")
- ("input[type=text]"
+ ("input[type=text]"
:display "inline"
- :border-bottom "thin dashed black"
+ :border-bottom "thin dashed black"
:font-style "italic" )
- (".frame"
+ (".frame"
:color "rgb(188,188,188)")
(".game-message" :font-style "italic")
(".change-name" :font-size "75%" :text-align "right")
(".messages-and-talk"
- :margin-top "2em"
+ :margin-top "2em"
:margin-left "1em"
:text-align "left")
(".robot" :font-style "italic")
- ('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+)
- :overflow "auto"
+ ('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+)
+ :overflow "auto"
:padding-right "0.5em"
:height "20em" )
(".play-game-description,.about"
@@ -286,7 +286,7 @@
(".game-header" :float "left")
(".close-game:before" :content "\"+ \"")
- (".players"
+ (".players"
:float "right"
:margin-top "2em"
)
@@ -301,23 +301,23 @@
(<h2 :font-size "2.5em")
(".webapp-section > ul > li" :padding-bottom "1em")
(".webapp-section > ul > li a.-replace-link-" :font-size "2em")
- (".separate"
+ (".separate"
:height "4em"
:border-right "2px solid black")
(".talk input[type=\"text\"]" :width "60%")
- (("input[type=submit]" <a "[onclick]")
- :display "inline"
+ (("input[type=submit]" <a "[onclick]")
+ :display "inline"
:text-decoration "none")
(".HEARTS, .DIAMONDS" :color "red")
(".HEARTS, .DIAMONDS, .CLUBS, .SPADES" :font-size "4em")
(".close-game" :text-align "right")
- ("[onclick],a,input[type=submit]"
+ ("[onclick],a,input[type=submit]"
:background-color "rgb(228,228,228)"
:cursor "pointer")
("#-async-status-"
:position "fixed"
:bottom "0em"
- :padding "0.2em 0.2em 0.2em 0.2em"
+ :padding "0.2em 0.2em 0.2em 0.2em"
:margin "0 0 0 0"
:right "0em"
:text-align "right"
@@ -331,74 +331,74 @@
(defsite *site*
:page-body-start (lambda(title)
- (declare (ignore title))
- `(<div :class "header"
- (<h1 :class "mopoko"
- (<A :href (page-link "/")
- :class "inherit"
- "mopoko " " prerelease" ))
- (<h4 :id ,tpd2.webapp:+html-id-async-status+ )
- (output-object-to-ml (webapp-frame))))
+ (declare (ignore title))
+ `(<div :class "header"
+ (<h1 :class "mopoko"
+ (<A :href (page-link "/")
+ :class "inherit"
+ "mopoko " " prerelease" ))
+ (<h4 :id ,tpd2.webapp:+html-id-async-status+ )
+ (output-object-to-ml (webapp-frame))))
:page-head (lambda(title)
- `(with-ml-output
- (<title "mopoko.com " (output-raw-ml ,title))
- (css)
- (webapp-default-page-head-contents)))
- :page-body-footer
+ `(with-ml-output
+ (<title "mopoko.com " (output-raw-ml ,title))
+ (css)
+ (webapp-default-page-head-contents)))
+ :page-body-footer
(lambda(title)
(declare (ignore title))
- `(with-ml-output
- (webapp-default-page-footer))))
+ `(with-ml-output
+ (webapp-default-page-footer))))
(with-compile-time-site (*site*)
(defun web-add-game (game-generator name)
(defpage-lambda (byte-vector-cat "/" name)
- (lambda ()
- (web-game-start game-generator))))
+ (lambda ()
+ (web-game-start game-generator))))
(defun webapp-play-bot (game-name bot)
(let ((game-state
- (make-web-state-from-frame)))
+ (make-web-state-from-frame)))
(launch-game game-name (list bot game-state))
(webapp ()
- (webapp-display game-state))))
-
+ (webapp-display game-state))))
+
(defun web-game-start (game-generator)
(let ((c (make-web-state-from-frame)))
(game-generator-join-or-start game-generator c)
(webapp ()
- (webapp-display c))))
-
+ (webapp-display c))))
+
(defpage "/" ()
(webapp ""
(webapp-select-one ""
- (loop for g being the hash-values of *games*
- when (game-generator-advertised g)
- collect g)
- :display (lambda(g) (output-raw-ml
- "Play " (game-generator-name g)))
- :describe (lambda (g)
- (let ((d (game-generator-description g)))
- (when d
- (<div :class "play-game-description"
- (output-raw-ml d)))))
- :replace
- (lambda(g)
- (web-game-start g)))
+ (loop for g being the hash-values of *games*
+ when (game-generator-advertised g)
+ collect g)
+ :display (lambda(g) (output-raw-ml
+ "Play " (game-generator-name g)))
+ :describe (lambda (g)
+ (let ((d (game-generator-description g)))
+ (when d
+ (<div :class "play-game-description"
+ (output-raw-ml d)))))
+ :replace
+ (lambda(g)
+ (web-game-start g)))
(html-collapser (<h3 "About mopoko.com")
- (<div :class "about"
-
- (<p (<a :href (page-link "/") "mopoko.com") " is a place to play
+ (<div :class "about"
+
+ (<p (<a :href (page-link "/") "mopoko.com") " is a place to play
games. Have fun!")
-
- (<p "When you choose to play a game, we wait a few seconds for
+
+ (<p "When you choose to play a game, we wait a few seconds for
someone else to join in. If nobody does, then a robot will join
the game. Each robot has a different style of play.")
-
- (<p "Please " (<a :href "mailto:john@fremlin.org" "email") " me
+
+ (<p "Please " (<a :href "mailto:john@fremlin.org" "email") " me
with your comments, advice and suggestions for a new game.")
-
- (<p "Thanks for visiting " (output-raw-ml "&mdash;") " John Fremlin " (<a :href "mailto:john@fremlin.org" "<john@fremlin.org>") ", 24 September 2009")
-
- (<p "PS. Look at the " (<a :href "http://www.github.com/vii/teepeedee2" "source code for this website") "."))))))
+
+ (<p "Thanks for visiting " (output-raw-ml "&mdash;") " John Fremlin " (<a :href "mailto:john@fremlin.org" "<john@fremlin.org>") ", 24 September 2009")
+
+ (<p "PS. Look at the " (<a :href "http://www.github.com/vii/teepeedee2" "source code for this website") "."))))))
View
118 src/http/dispatcher.lisp
@@ -6,33 +6,33 @@
(error-responder 'default-http-error-page))
(defun dispatch-servestate (con done *servestate*)
- (dispatcher-respond (find-dispatcher (first (servestate-host*)))
- con done))
+ (dispatcher-respond (find-dispatcher (first (servestate-host*)))
+ con done))
(defun-speedy start-http-response (&key (banner (force-byte-vector "200 OK"))
- (content-type #.(byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+)))
+ (content-type #.(byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+)))
(setf (servestate-response*)
- (with-sendbuf ()
- "HTTP/1.1 " banner +newline+
- content-type)))
+ (with-sendbuf ()
+ "HTTP/1.1 " banner +newline+
+ content-type)))
(defun-speedy map-http-params (func)
(declare (dynamic-extent func) (type (function (simple-byte-vector simple-byte-vector) t) func))
(labels (
- (f (name value)
- (funcall func (url-encoding-decode name) (url-encoding-decode value)))
- (parse-params (str)
- (when str
- (match-bind ( (* name "=" value (or (last) "&")
- '(f name value)))
- str)))
- (parse-cookie-params (cookies)
- (loop for str in cookies do
- (match-bind ( (* name "=" value (or (last) "," ";")
- '(f name value)))
- str))))
+ (f (name value)
+ (funcall func (url-encoding-decode name) (url-encoding-decode value)))
+ (parse-params (str)
+ (when str
+ (match-bind ( (* name "=" value (or (last) "&")
+ '(f name value)))
+ str)))
+ (parse-cookie-params (cookies)
+ (loop for str in cookies do
+ (match-bind ( (* name "=" value (or (last) "," ";")
+ '(f name value)))
+ str))))
(declare (inline parse-cookie-params parse-params f)
- (dynamic-extent #'parse-params #'parse-cookie-params #'f))
+ (dynamic-extent #'parse-params #'parse-cookie-params #'f))
(parse-params (servestate-query-string*))
(parse-params (servestate-post-parameters*))
(parse-cookie-params (servestate-cookie*))))
@@ -40,24 +40,24 @@
(defmacro with-http-params (bindings &body body)
(with-unique-names (f pname pvalue)
`(let ,(loop for b in bindings for (n default) = (force-list b)
- collect `(,n ,default))
+ collect `(,n ,default))
(flet ((,f (,pname ,pvalue)
- (declare (type simple-byte-vector ,pname ,pvalue))
- (case-match-fold-ascii-case ,pname
- ,@(loop for b in bindings
- collect
- (destructuring-bind
- (var &optional default &key conv (name (force-byte-vector var)))
- (force-list b)
- (declare (ignore default))
- `(,(force-byte-vector name)
- (setf ,var ,(if conv
- `(,conv ,pvalue)
- pvalue)))
- )))))
- (declare (inline ,f) (dynamic-extent #',f))
- (map-http-params #',f)
- (locally ,@body)))))
+ (declare (type simple-byte-vector ,pname ,pvalue))
+ (case-match-fold-ascii-case ,pname
+ ,@(loop for b in bindings
+ collect
+ (destructuring-bind
+ (var &optional default &key conv (name (force-byte-vector var)))
+ (force-list b)
+ (declare (ignore default))
+ `(,(force-byte-vector name)
+ (setf ,var ,(if conv
+ `(,conv ,pvalue)
+ pvalue)))
+ )))))
+ (declare (inline ,f) (dynamic-extent #',f))
+ (map-http-params #',f)
+ (locally ,@body)))))
(defmacro with-http-headers (() &body body)
`(with-sendbuf-continue ((servestate-response-as-sendbuf*))
@@ -79,30 +79,30 @@
(my-defun dispatcher respond (con done)
(let ((f (gethash (servestate-path*) (my paths))))
- (handler-case
- (cond
- (f
- (locally (declare (optimize speed) (type function f))
- (funcall f me con done)
- (values)))
- (t
- ;(format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
- (respond-http con done :banner (force-byte-vector "404 Not found")
- :body (funcall (my error-responder) me))))
+ (handler-case
+ (cond
+ (f
+ (locally (declare (optimize speed) (type function f))
+ (funcall f me con done)
+ (values)))
+ (t
+ ;(format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
+ (respond-http con done :banner (force-byte-vector "404 Not found")
+ :body (funcall (my error-responder) me))))
(error (e)
- (format *error-output* "~&PAGE ERROR ~A~&--- ~A~&-AGAIN PAGE ERROR ~A~&