Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

added atom feeds (still rather weird)

commit bf7ab7f7e0dc7c060fecac69d90ea0ca0c481ee8 1 parent 6ea6156
John Fremlin authored
18 src/blog/blog.lisp
@@ -22,13 +22,23 @@
22 22 (my set-page))
23 23 me)
24 24
  25 +(my-defun blog ready-entries (&key (start 0))
  26 + (subseq (remove-if-not 'entry-ready (my entries)) start))
  27 +
  28 +(my-defun blog feed-url ()
  29 + (byte-vector-cat (my link-base) "feed.atom"))
  30 +
25 31 (my-defun blog set-page ()
26 32 (with-site ((my site))
  33 + (defpage-lambda (my feed-url)
  34 + (lambda ()
  35 + (my feed)))
  36 +
27 37 (defpage-lambda (my link-base)
28 38 (lambda(&key n)
29   - (webapp (my name)
  39 + (webapp ((my name) :head-contents (<link :rel "alternate" :type "application/atom+xml" :href (my feed-url)))
30 40 (let ((n (byte-vector-parse-integer n)))
31   - (let ((entries (subseq (remove-if-not 'entry-ready (my entries)) n)) (count 10))
  41 + (let ((entries (my ready-entries :start n)) (count 10))
32 42 (<div :class "blog"
33 43 (loop while entries
34 44 repeat count
@@ -40,3 +50,7 @@
40 50 (<p :class "next-entries" (<a :href (page-link (my link-base) :n (force-byte-vector (+ n count))) "More entries"))))))))
41 51 ((n (force-byte-vector 0))))))
42 52
  53 +(my-defun blog last-updated ()
  54 + (loop for e in (my entries)
  55 + when (entry-ready e)
  56 + maximizing (entry-time e)))
5 src/blog/entry.lisp
@@ -37,9 +37,8 @@
37 37
38 38 (defun time-string (&optional (ut (get-universal-time)))
39 39 (multiple-value-bind
40   - (second minute hour date month year day daylight-p zone)
  40 + (second minute hour date month year)
41 41 (decode-universal-time ut 0)
42   - (declare (ignore day daylight-p zone))
43 42 (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D GMT" year month date hour minute second)))
44 43
45 44 (my-defun entry filename ()
@@ -104,7 +103,7 @@
104 103 (with-site ((its site (my blog)))
105 104 (defpage-lambda (my url-path)
106 105 (lambda()
107   - (webapp (my combined-title)
  106 + (webapp ((my combined-title))
108 107 (output-object-to-ml me))))))
109 108
110 109 (my-defun entry read-paragraphs-from-buffer (buffer)
24 src/blog/feed.lisp
... ... @@ -0,0 +1,24 @@
  1 +(in-package #:tpd2.blog)
  2 +
  3 +(my-defun blog feed (&key (count 10))
  4 + (values
  5 + (with-ml-output-start
  6 + (output-raw-ml "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
  7 + (tpd2.ml.atom:<feed
  8 + (tpd2.ml.atom:<title
  9 + (my name))
  10 + (tpd2.ml.atom:<link
  11 + :href (my link-base))
  12 + (tpd2.ml.atom:<updated
  13 + (w3c-timestring (my last-updated)))
  14 + (loop repeat count
  15 + for entry in (my ready-entries) do
  16 + (tpd2.ml.atom:<entry
  17 + (tpd2.ml.atom:<title (entry-title entry))
  18 + (tpd2.ml.atom:<updated (w3c-timestring (entry-time entry)))
  19 + (tpd2.ml.atom:<id (entry-url-path entry))
  20 + (tpd2.ml.atom:<link (entry-url-path entry))
  21 + (tpd2.ml.atom:<content :type "text/html"
  22 + (loop for p in (entry-paragraphs entry) do
  23 + (<p p ))))))) ; if there are any XML errors the whole feed won't display
  24 + (byte-vector-cat "Content-Type: application/atom+xml" tpd2.io:+newline+)))
2  src/game/card.lisp
... ... @@ -1,7 +1,7 @@
1 1 (in-package #:tpd2.game)
2 2
3 3 (eval-always
4   - (defconstant +suits+ '(:clubs :hearts :spades :diamonds))
  4 + (define-constant +suits+ '(:clubs :hearts :spades :diamonds) :test 'equal)
5 5 (defconstant +cards-per-suit+ 13))
6 6
7 7 (defstruct card
1  src/http/dispatcher.lisp
@@ -14,7 +14,6 @@
14 14 (with-sendbuf (response)
15 15 "HTTP/1.1 " code " " banner +newline+
16 16 "Content-Length: " (sendbuf-len body) +newline+
17   - "Content-Type: text/html;charset=utf-8" +newline+
18 17 headers
19 18 +newline+
20 19 body))
3  src/io/con.lisp
@@ -54,7 +54,8 @@
54 54 (timeout-set (my timeout) delay)
55 55 (values))
56 56
57   -(defconstant +newline+ (force-byte-vector #(13 10)))
  57 +(define-constant +newline+ (force-byte-vector #(13 10))
  58 + :test 'equalp)
58 59
59 60 (my-defun con set-callback (func)
60 61 (setf (my ready-callback) func))
4 src/io/syscalls.lisp
@@ -146,8 +146,8 @@
146 146 (def-simple-syscall close
147 147 (fd :int))
148 148
149   -(defconstant +SIG_IGN+ (cffi:make-pointer 1))
150   -(defconstant +SIG_DFL+ (cffi:make-pointer 0))
  149 +(define-constant +SIG_IGN+ (cffi:make-pointer 1) :test 'cffi:pointer-eq)
  150 +(define-constant +SIG_DFL+ (cffi:make-pointer 0) :test 'cffi:pointer-eq)
151 151 (defconstant +SIGPIPE+ 13)
152 152
153 153 (cffi:defcfun ("signal" syscall-signal)
5 src/lib/byte-vector.lisp
@@ -37,7 +37,7 @@
37 37 do (setf (aref ret i) arg))
38 38 ret))
39 39
40   -(defconstant +byte-to-digit-table+
  40 +(define-constant +byte-to-digit-table+
41 41 (make-array 256 :element-type '(integer -1 36)
42 42 :initial-contents (loop for i from 0 below 256
43 43 collect
@@ -52,7 +52,8 @@
52 52 (or (in-range #\a #\z i 10)
53 53 (in-range #\A #\Z i 10)
54 54 (in-range #\0 #\9 i 0)
55   - -1)))))
  55 + -1))))
  56 + :test 'equalp)
56 57
57 58 (declaim-defun-consistent-ftype byte-to-digit ((unsigned-byte 8)) (integer -1 36))
58 59 (defun-consistent byte-to-digit (byte)
4 src/lib/one-liners.lisp
@@ -63,3 +63,7 @@
63 63 `(debug-assert (not 'reached-here)))
64 64
65 65
  66 +(defmacro defconstant-string (name value &optional documentation)
  67 + `(define-constant ,name ,value
  68 + :test 'string=
  69 + ,@(when documentation `((:documentation ,documentation)))))
2  src/lib/utils.lisp
@@ -50,4 +50,4 @@
50 50
51 51 (defun backtrace-description (err)
52 52 (format nil "ERROR ~A:~&~A" (with-output-to-string (*standard-output*) (describe err))
53   - (trivial-backtrace:get-backtrace err)))
  53 + (trivial-backtrace:backtrace-string)))
5 src/ml/css.lisp
@@ -2,7 +2,7 @@
2 2
3 3 ; From http://www.w3.org/TR/REC-CSS2/propidx.html
4 4 ; if you want more just use "strings"
5   -(defconstant +css-properties+ '(
  5 +(define-constant +css-properties+ '(
6 6 :azimuth
7 7 :background
8 8 :background-color
@@ -147,7 +147,8 @@
147 147 :x-opacity
148 148 :x-column-width
149 149 :x-column-gap
150   - ))
  150 + )
  151 + :test 'equalp)
151 152
152 153 ;; Write CSS like this: (("p.asdfsaf" "p + p") :property "value" :property "value")
153 154
7 src/packages.lisp
@@ -5,7 +5,7 @@
5 5 (defpackage #:teepeedee2.lib
6 6 (:nicknames #:tpd2.lib)
7 7 (:use #:common-lisp #:iter #:cl-irregsexp.bytestrings)
8   - (:import-from #:cl-utilities #:with-unique-names)
  8 + (:import-from #:alexandria #:with-unique-names #:define-constant)
9 9 (:import-from #:trivial-garbage #:finalize #:cancel-finalization)
10 10 (:import-from #:cl-cont #:call/cc #:with-call/cc)
11 11 (:import-from #:cl-irregsexp
@@ -48,7 +48,8 @@
48 48
49 49 #:with-unique-names
50 50 #:once-only
51   -
  51 + #:define-constant
  52 + #:defconstant-string
52 53
53 54 #:copy-byte-vector
54 55 #:make-byte-vector
@@ -236,6 +237,8 @@
236 237 #:js-html-script
237 238 #:js-attrib
238 239 #:js-to-string
  240 +
  241 + #:w3c-timestring
239 242 ))
240 243
241 244 (eval-when (:compile-toplevel :load-toplevel :execute)
10 src/truc/robots.lisp
@@ -26,7 +26,7 @@
26 26 (t my-best-card))))))
27 27
28 28
29   -(defconstant +best-starts+ #(0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 0 2 2 0 2 2 2 2 0 2 2 2
  29 +(define-constant +best-starts+ #(0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 0 2 2 0 2 2 2 2 0 2 2 2
30 30 0 0 2 2 0 2 2 2 0 0 0 2 0 2 2 2 2 0 0 0 0 2 2 2 2 2 0 0 0 2 2 2 2 2 2 2
31 31 2 0 1 1 1 1 1 1 2 1 2 1 1 2 2 2 2 1 1 0 1 1 2 2 2 1 1 1 0 1 1 2 2 1 2 1
32 32 1 0 1 2 2 1 2 2 1 1 0 1 2 1 2 2 2 2 1 0 0 2 2 2 2 2 2 2 2 1 2 1 1 2 2 2
@@ -41,10 +41,11 @@
41 41 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 2 2 2 2 2 0 0 2 1 2 2 2 2 1 0 2 2 1 2
42 42 2 1 1 0 2 2 2 1 2 1 1 0 2 2 2 2 1 1 1 0 2 2 1 1 1 1 1 0 0 1 1 1 1 1 0 0
43 43 0 0 0 0 0 0 0 0)
44   - "Given the hand described by the index, 0 means play the highest card, 1 the middle card and 2 the lowest card first")
  44 + :documentation "Given the hand described by the index, 0 means play the highest card, 1 the middle card and 2 the lowest card first"
  45 + :test 'equalp)
45 46
46 47
47   -(defconstant +three-card-win-probabilities+
  48 +(define-constant +three-card-win-probabilities+
48 49 #(0 1/1218 1/522 11/3654 5/1218 19/3654 23/3654 3/406 1/1218 79/3654 44/1827
49 50 71/1827 122/1827 197/1827 296/1827 419/1827 1/522 44/1827 101/3654 82/1827
50 51 5/63 8/63 49/261 478/1827 11/3654 71/1827 82/1827 143/1827 64/609 323/1827
@@ -100,7 +101,8 @@
100 101 298/609 55/87 179/261 1375/1827 1457/1827 1651/1827 1 892/1827 49/87
101 102 170/261 1375/1827 1468/1827 1574/1827 1720/1827 1 373/609 132/203 428/609
102 103 1457/1827 1574/1827 545/609 1765/1827 1 2609/3654 1441/1827 1558/1827
103   - 1651/1827 1720/1827 1765/1827 3575/3654 1 1 1 1 1 1 1 1 1))
  104 + 1651/1827 1720/1827 1765/1827 3575/3654 1 1 1 1 1 1 1 1 1)
  105 + :test 'equalp)
104 106
105 107 (my-defun truc-player win-probability ()
106 108 "Rough and ready win probability not taking into account who starts or anything much"
9 src/truc/truc.lisp
... ... @@ -1,9 +1,10 @@
1 1 (in-package #:tpd2.game.truc)
2 2
3   -(defconstant +truc-ranking+ '(6 7 0 12 11 10 9 8))
4   -(defconstant +truc-deck+
5   - (mapcar 'card-number
6   - (loop for s in +suits+ append (loop for i in +truc-ranking+ collect (make-card :suit s :value i)))))
  3 +(define-constant +truc-ranking+ '(6 7 0 12 11 10 9 8) :test 'equal)
  4 +(define-constant +truc-deck+
  5 + (map 'vector 'card-number
  6 + (loop for s in +suits+ append (loop for i in +truc-ranking+ collect (make-card :suit s :value i))))
  7 + :test 'equalp)
7 8 (defconstant +truc-winning-stack+ 12)
8 9
9 10 (defgame truc ()
16 src/webapp/html-constants.lisp
... ... @@ -1,14 +1,14 @@
1 1 (in-package #:tpd2.webapp)
2 2
3   -(defconstant +channel-page-name+ "/*channel*")
  3 +(defconstant-string +channel-page-name+ "/*channel*")
4 4
5   -(defconstant +action-page-name+ "/*action*")
  5 +(defconstant-string +action-page-name+ "/*action*")
6 6
7   -(defconstant +action-form-class+ "-action-form-")
8   -(defconstant +action-link-class+ "-action-link-")
9   -(defconstant +replace-link-class+ "-replace-link-")
  7 +(defconstant-string +action-form-class+ "-action-form-")
  8 +(defconstant-string +action-link-class+ "-action-link-")
  9 +(defconstant-string +replace-link-class+ "-replace-link-")
10 10
11   -(defconstant +html-id-async-status+ "-async-status-")
12   -(defconstant +html-class-scroll-to-bottom+ "-scroll-to-bottom-")
13   -(defconstant +html-class-collapsed+ "-collapsed-")
  11 +(defconstant-string +html-id-async-status+ "-async-status-")
  12 +(defconstant-string +html-class-scroll-to-bottom+ "-scroll-to-bottom-")
  13 +(defconstant-string +html-class-collapsed+ "-collapsed-")
14 14
5 src/webapp/names.lisp
... ... @@ -1,6 +1,6 @@
1 1 (in-package #:tpd2.webapp)
2 2
3   -(defconstant +names+ '("Mildred"
  3 +(define-constant +names+ #("Mildred"
4 4 "Henry"
5 5 "Alice"
6 6 "Walter"
@@ -1980,7 +1980,8 @@
1980 1980 "Lenord"
1981 1981 "Macy"
1982 1982 "Arden"
1983   - "Paralee"))
  1983 + "Paralee")
  1984 + :test 'equalp)
1984 1985
1985 1986 (defun-speedy random-letter ()
1986 1987 (code-char (+ (char-code #\A) (random 26))))
8 src/webapp/page.lisp
... ... @@ -1,14 +1,16 @@
1 1 (in-package #:tpd2.webapp)
2 2
3 3 (defvar *webapp-frame*)
4   -(defconstant +webapp-frame-id-param+ (force-byte-vector ".webapp-frame."))
  4 +(define-constant +webapp-frame-id-param+ (force-byte-vector ".webapp-frame.")
  5 + :test 'equalp)
5 6
6   -(defconstant +web-safe-chars+
  7 +(define-constant +web-safe-chars+
7 8 (force-byte-vector
8 9 (append (loop for c from (char-code #\A) to (char-code #\Z) collect c)
9 10 (loop for c from (char-code #\a) to (char-code #\z) collect c)
10 11 (loop for c from (char-code #\0) to (char-code #\9) collect c)
11   - (mapcar 'char-code '(#\- #\_)))))
  12 + (mapcar 'char-code '(#\- #\_))))
  13 + :test 'equalp)
12 14
13 15 (defun generate-args-for-defpage-from-params (params-var defaulting-lambda-list)
14 16 (let ((arg-names (mapcar 'force-first defaulting-lambda-list))
10 src/webapp/site.lisp
... ... @@ -1,8 +1,8 @@
1 1 (in-package #:tpd2.webapp)
2 2
3 3 (eval-always
4   - (defconstant +site-customization-funcs+ '(page-head page-body-start page-body-footer))
5   - (defconstant +site-customization-func-args+ '(title)))
  4 + (define-constant +site-customization-funcs+ '(page-head page-body-start page-body-footer) :test 'equalp)
  5 + (define-constant +site-customization-func-args+ '(title) :test 'equalp))
6 6
7 7 (defparameter *current-site* nil)
8 8
@@ -14,9 +14,9 @@
14 14 (runtime-name '*current-site*)
15 15 (dispatcher *default-dispatcher*)
16 16 (page-head (lambda(title)
17   - `(<head
18   - (<title ,title)
19   - (webapp-default-page-head-contents))))
  17 + `(with-ml-output
  18 + (<title ,title))
  19 + (webapp-default-page-head-contents)))
20 20 (page-body-start
21 21 (lambda(title)
22 22 `(<h1 ,title)))
42 src/webapp/webapp.lisp
@@ -13,32 +13,38 @@
13 13 (defmacro ml-to-byte-vector (ml)
14 14 `(sendbuf-to-byte-vector (with-ml-output-start ,ml)))
15 15
16   -(defmacro webapp-ml (title &body body)
  16 +(defmacro webapp-ml (title-and-options &body body)
17 17 (with-unique-names (title-ml)
18   - `(let ((,title-ml
19   - (ml-to-byte-vector ,title)))
20   - (setf (webapp-frame-var 'actions) nil)
21   - (with-frame-site
22   - (with-ml-output-start
  18 + (destructuring-bind (title &key head-contents)
  19 + (force-list title-and-options)
  20 + `(let ((,title-ml
  21 + (ml-to-byte-vector ,title)))
  22 + (setf (webapp-frame-var 'actions) nil)
  23 + (values
  24 + (with-frame-site
  25 + (with-ml-output-start
23 26 (output-raw-ml "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
24   - " \"http://www.w3.org/TR/html4/loose.dtd\">")
25   - (<html
26   - (current-site-call page-head ,title-ml)
27   - (<body
28   - (current-site-call page-body-start ,title-ml)
29   - ,@body
30   - (current-site-call page-body-footer ,title-ml))))))))
31   -
32   -(defmacro webapp-lambda (title &body body)
  27 + " \"http://www.w3.org/TR/html4/loose.dtd\">")
  28 + (<html
  29 + (<head
  30 + (current-site-call page-head ,title-ml)
  31 + ,head-contents)
  32 + (<body
  33 + (current-site-call page-body-start ,title-ml)
  34 + ,@body
  35 + (current-site-call page-body-footer ,title-ml)))))
  36 + (byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+))))))
  37 +
  38 +(defmacro webapp-lambda (title-and-options &body body)
33 39 (with-unique-names (l)
34 40 `(labels ((,l ()
35 41 (setf (frame-current-page (webapp-frame))
36 42 #',l)
37   - (webapp-ml ,title ,@body)))
  43 + (webapp-ml ,title-and-options ,@body)))
38 44 #',l)))
39 45
40   -(defmacro webapp (title &body body)
41   - `(funcall (webapp-lambda ,title ,@body)))
  46 +(defmacro webapp (title-and-options &body body)
  47 + `(funcall (webapp-lambda ,title-and-options ,@body)))
42 48
43 49 (defmacro link-to-webapp (title &body body)
44 50 (with-unique-names (title-ml)
15 teepeedee2-test.asd
... ... @@ -0,0 +1,15 @@
  1 +(asdf:defsystem :teepeedee2-test
  2 + :name "teepeedee2 tests"
  3 + :author "John Fremlin <john@fremlin.org>"
  4 + :version "prerelease"
  5 + :description "Tests for teepeedee2"
  6 + :components ((:module :t
  7 +
  8 + :components (
  9 + (:file "suite")
  10 + (:file "io" :depends-on ("suite"))
  11 + (:file "http" :depends-on ("suite"))
  12 + )))
  13 + :depends-on (
  14 + :fiveam
  15 + :teepeedee2))
19 teepeedee2.asd
@@ -13,6 +13,7 @@
13 13 (setf sb-ext:*inline-expansion-limit* 50)
14 14
15 15 (pushnew "../cl-irregsexp/" asdf:*central-registry* :test #'equal)
  16 +(pushnew "../trivial-backtrace/" asdf:*central-registry* :test #'equal)
16 17
17 18 #+tpd2-debug
18 19 (progn
@@ -76,7 +77,8 @@
76 77 (:file "define-dtd" :depends-on ("object-to-ml"))
77 78 (:file "css" :depends-on ("html"))
78 79 (:file "js" :depends-on ("html"))
79   - (:file "html" :depends-on ("define-dtd"))))
  80 + (:file "html" :depends-on ("define-dtd"))
  81 + (:file "atom" :depends-on ("define-dtd"))))
80 82 (:module :datastore
81 83 :depends-on (:lib)
82 84 :components ((:file "datastore")))
@@ -104,26 +106,19 @@
104 106 (:module :blog
105 107 :depends-on (:webapp :ml :datastore)
106 108 :components ((:file "entry")
  109 + (:file "feed" :depends-on ("blog"))
107 110 (:file "blog" :depends-on ("entry"))))
108 111 (:module :truc
109 112 :depends-on (:game)
110 113 :components ( (:file "truc") (:file "web" :depends-on ("truc"))
111   - (:file "robots" :depends-on ("truc"))))))
112   -
113   - (:module :t
114   - :depends-on (:src)
115   - :components (
116   - (:file "suite")
117   - (:file "io" :depends-on ("suite"))
118   - (:file "http" :depends-on ("suite"))
119   - )))
  114 + (:file "robots" :depends-on ("truc")))))))
120 115 :depends-on (
121 116 :trivial-garbage
122 117 :cl-cont
123 118 :cffi
124 119 :iterate
125   - :fiveam
126   - :cl-utilities
  120 + :alexandria
127 121 :cl-irregsexp
128 122 :trivial-backtrace
129 123 :parenscript))
  124 +

0 comments on commit bf7ab7f

Please sign in to comment.
Something went wrong with that request. Please try again.