From caf961831278c981ea2ccbc7b689bf1b71849114 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 24 Feb 2008 21:21:41 +0100 Subject: atom feed maybe working --- tekuti/comment.scm | 122 +++++++++++++++++++++++++++++----------------------- tekuti/config.scm | 6 ++- tekuti/git.scm | 2 +- tekuti/mod-lisp.scm | 18 ++++++-- tekuti/page.scm | 78 +++++++++++++++++++++++++++++---- tekuti/post.scm | 2 +- tekuti/web.scm | 14 ++++-- 7 files changed, 169 insertions(+), 73 deletions(-) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index 93d519d..2454516 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -34,7 +34,7 @@ #:use-module (sxml transform) #:use-module (match-bind) #:export (comment-from-object comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date - bad-new-comment-post?)) + bad-new-comment-post? make-new-comment)) (define *comment-spec* `((timestamp . ,string->number))) @@ -102,7 +102,7 @@ `(p "Please pretend to specify a valid email address."))) (define (urlish? x) - (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/.*$" + (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/[a-zA-Z0-9$_.+!*'(),;/?:@&=-]*$" x (_ . args) x #f)) @@ -213,42 +213,44 @@ (if (not (assoc name dent-names)) (error "file already removed" name))) names)) - (define (collect proc l) - (reverse! (fold (lambda (x y) - (let ((foo (proc x))) - (if foo (cons foo y) y))) - '() l))) - (define (level-down x) - (cons (cdar x) (cdr x))) - - (let-values (((dents) (git-ls-tree treeish #f)) + (let-values (((dents) (if treeish (git-ls-tree treeish #f) '())) ((ladd dadd) (partition local? add)) ((lremove dremove) (partition local? remove)) ((lchange dchange) (partition local? change))) - (assert-added-files-not-present (map caadr ladd) dents) + (assert-added-files-not-present (map cadr ladd) dents) (assert-referenced-files-present - (append (map cadr lremove) (map caadr lchange)) dents) - - (make-tree - (append - (map cdr ladd) - (collect - (lambda (dent) - (cond - ((member (car dent) (map cadr lremove)) - #f) - ((member (car dent) (map caadr lchange)) - (cadr lchange)) - ((and (equal? (caddr dent) "tree") - (or (member (car dent) - (map cadr (append dadd dremove dchange))))) - `(,(car dent) (make-tree-deep (cadr dent) - (map level-down dadd) - (map level-down dremove) - (map level-down dchange)) - ,(caddr dent) ,(cadddr dent))) - (else dent)))))))) - + (append (map cdr lremove) (map caar lchange)) dents) + (pk 'make-tree-deep treeish add remove change) + (make-tree-full + (pk 'making (append + (map cdr ladd) + (filter-map + (lambda (dent) + (cond + ((member (car dent) (map cdr lremove)) + #f) + ((member (car dent) (map cadr lchange)) + (cdr lchange)) + ((and (equal? (caddr dent) "tree") + (member (car dent) + (map caar (append dadd dremove dchange)))) + (pk 'hi! dent (map caar (append dadd dremove dchange))) + (let ((level-down (lambda (x) + (if (equal? (caar x) (car dent)) + (cons (cdar x) (cdr x)) + #f)))) + (list (car dent) + (make-tree-deep (cadr dent) + (filter-map level-down dadd) + (filter-map level-down dremove) + (filter-map level-down dchange)) + "tree" "040000"))) + (else dent))) + (append (filter-map (lambda (x) + (and (not (assoc (caar x) dents)) + (list x "tree" #f #f)) + dadd)) + dents))))))) (define (mutate-tree master add remove change message) (let ((tree (make-tree-deep master add remove change))) @@ -256,9 +258,9 @@ (git* `("commit-tree" ,tree "-p" ,master) #:input message #:env '("GIT_COMMMITTER=tekuti"))))) -(define (update-master master proc) - (let lp ((master master)) - (let ((commit (proc master)) (count 5)) +(define (update-master proc) + (let lp ((master (git-rev-parse "master")) (count 5)) + (let ((commit (proc master))) (cond ((zero? count) (error "my god, we looped 5 times" commit)) @@ -269,21 +271,31 @@ (pk "failed to update the master ref, trying again...") (lp (git-rev-parse "master") (1- count))))))) -(define (make-new-comment post content) - (let ((content-sha1 (make-blob -(assoc-ref post-data "comment"))) - (metadata-sha1 (make-blob (with-output-to-string - (lambda () - (write ) - ) -) metadata))) - (update-master - master - (lambda (master) - (mutate-tree master - `(((,(assq-ref post 'key) "comments" ,comment-key) - ("content" ,content-sha1 "blob" "100644")) - ((,(assq-ref post 'key) "metadata" ,comment-key) - ("metadata" ,metadata-sha1 "blob" "100644"))) - '() - '()))))) +(define (make-new-comment post post-data) + (let ((content (assoc-ref post-data "comment")) + (author (assoc-ref post-data "author")) + (email (assoc-ref post-data "email")) + (url (assoc-ref post-data "url"))) + (let ((sha1 (create-blob + (with-output-to-string + (lambda () + (for-each + (lambda (pair) + (format #t "~a: ~a\n" (car pair) (cdr pair))) + `((timestamp . ,(time-second (current-time))) + (author . ,(string-join + ;; security foo + (string-split author #\newline) + " ")) + (author_email . ,email) + (author_url . ,url))) + (display "\n") + (display content)))))) + (update-master + (lambda (master) + (mutate-tree master + `(((,(assq-ref post 'key) "comments") . (,sha1 ,sha1 "blob" "100644"))) + '() + '() + "new comment")))))) + diff --git a/tekuti/config.scm b/tekuti/config.scm index 3899f2d..e3d605f 100644 --- a/tekuti/config.scm +++ b/tekuti/config.scm @@ -27,7 +27,8 @@ (define-module (tekuti config) #:use-module (tekuti util) #:export (*host* *port* *backlog* *git-dir* *git* *public-url-base* - *private-url-base* *debug* *admin-user* *admin-pass*)) + *private-url-base* *debug* *admin-user* *admin-pass* + *title* *name*)) (define *host* "127.0.0.1") (define *port* 8081) @@ -39,3 +40,6 @@ (define *debug* #t) (define *admin-user* "admin") (define *admin-pass* "totingiini") +(define *title* "My blog") +(define *subtitle* "Just a blog, ok") +(define *name* "Joe Schmo") diff --git a/tekuti/git.scm b/tekuti/git.scm index 09c12e2..aede954 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -63,7 +63,7 @@ (string->list str)) (display #\')))) -(define *debug* #f) +(define *debug* #t) (define (trc . args) (if *debug* (apply pk args) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index da2e7fa..c17a3ac 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -69,8 +69,20 @@ (display "end\n" port)) (define (write-body request socket) - (display (rref request 'doctype "") socket) - (sxml->xml (rref request 'sxml '()) socket)) + (let ((sxml (rref request 'sxml #f))) + (if sxml + (begin (display (rref request 'doctype "") socket) + (sxml->xml sxml socket)) + (display "" socket)))) + +(define (request-output-headers request) + (let ((rheads '(("Content-Type" . output-type)))) + (map (lambda (h) + (cons (car h) + (or (and=> (assoc-ref (car h) rheads) + (lambda (k) (rref request k #f))) + (cdr h)))) + (rref request 'output-headers '())))) (define (connection-received socket sockaddr index) (let* ((headers (pk (read-headers socket))) @@ -84,7 +96,7 @@ (let ((res (handle-request (make-request 'headers headers 'post-data post-data) index))) - (write-headers (rref res 'output-headers '()) socket) + (write-headers (request-output-headers res) socket) (write-body res socket))) (lambda args (write-headers '(("Status" . "500 Internal Server Error") diff --git a/tekuti/page.scm b/tekuti/page.scm index dc26b43..bf8d7c0 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -51,11 +51,16 @@ page-debug page-search page-show-post + page-feed-atom + page-feed-rss2 page-debug page-not-found)) -(define (relurl path . body) - `(a (@ (href ,(string-append *public-url-base* path))) +(define (relurl path) + (string-append *public-url-base* path)) + +(define (rellink path . body) + `(a (@ (href ,(relurl path))) ,@body)) (define (make-post-key . parts) @@ -107,7 +112,7 @@ (assq-ref index 'posts) n)) (rcons* request - 'body `(,(sidebar-ul `((li (h2 ,(relurl "admin/posts" "posts")) + 'body `(,(sidebar-ul `((li (h2 ,(rellink "admin/posts" "posts")) (ul ,@(post-links 10))) (li (h2 "recent comments") (p "ain't got none")))) @@ -115,12 +120,12 @@ ,(post-editing-form #f)))))) (define (admin-post-link post) - (relurl (string-append "admin/posts/" + (rellink (string-append "admin/posts/" (url:encode (assq-ref post 'key))) (assq-ref post 'title))) (define (post-link post) - (relurl (string-append "archives/" (url:decode (assq-ref post 'key))) + (rellink (string-append "archives/" (url:decode (assq-ref post 'key))) (assq-ref post 'title))) (define (page-admin-posts request index) @@ -130,7 +135,7 @@ (define (post-headers) (map (lambda (post) ;; double-encoding is a hack to trick apache - `(h3 ,(relurl (string-append "admin/posts/" (url:encode (assq-ref post 'key))) + `(h3 ,(rellink (string-append "admin/posts/" (url:encode (assq-ref post 'key))) (assq-ref post 'title)))) (assq-ref index 'posts))) (rcons* request @@ -262,8 +267,9 @@ (rcons* request 'body `((p "Bad post data: " ,reason))))) (else - (rcons* request - 'body `((p "hey hey hey like fat albert"))))))) + (let ((comment (make-new-comment (post-from-tree slug tree) data))) + (rcons* request + 'body `((p "hey hey hey like fat albert" ,comment)))))))) (else (page-not-found request index))))) @@ -356,3 +362,59 @@ 'status 404 'body `((h1 "Page not found") (p "Unknown path: " ,(rref request 'path-str))))) + +(define (page-feed-rss2 request index) + (not-implemented request index)) + + +(define (rfc822-date->timestamp str) + (+ (time-second (date->time-utc + (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT"))) + (date-zone-offset (current-date)))) + +(define (timestamp->atom-date timestamp) + (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) + "~Y-~m-~dT~H:~M:~SZ")) + +(define (page-feed-atom request index) + (let ((last-modified (let ((posts (assq-ref index 'posts))) + (and (pair? posts) + (assq-ref (car posts) 'timestamp))))) + (cond + ((let ((since (assoc-ref (rref request 'headers '()) + "If-Modified-Since"))) + (and since (>= (rfc822-date->timestamp since) last-modified))) + (rcons* request + 'status 304 + 'doctype #f)) + (else + (rcons* request + 'doctype "" + 'output-type "application/atom+xml" + 'sxml `(feed + (@ (xmlns "http://www.w3.org/2005/Atom") + (xml:base ,(relurl "feed/atom"))) + (title (@ (type "text")) ,*title*) + (subtitle (@ (type "text")) ,*subtitle*) + (updated ,(timestamp->atom-date last-modified)) + (generator (@ (uri "http://wingolog.org/software/tekuti") + (version "what")) + "tekuti") + (link (@ (rel "alternate") (type "text/html") + (href ,(relurl "")))) + (id ,(relurl "feed/atom")) + (link (@ (rel "self") (type "application/atom+xml") + (href ,(relurl "feed/atom")))) + ,@(map + (lambda (post) + `(entry + (author (name ,*name*) (uri ,(relurl ""))) + (title (@ (type "text")) ,(assq-ref post 'title)) + (id ,(assq-ref post 'key)) + (published ,(timestamp->atom-date + (assq-ref post 'timestamp))) + (content (@ (type "xhtml") + (xmlns "http://www.w3.org/1999/xhtml")) + (div ,(post-sxml-content post))))) + (take-max (assq-ref index 'posts) 10)))))))) + diff --git a/tekuti/post.scm b/tekuti/post.scm index 7177d12..cafd4e0 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -166,7 +166,7 @@ ,(comment-form post "" "" "" "")))))) (define (post-n-comments post) - (length (git-ls-subdirs (assq-ref post 'sha1) "comments/"))) + (length (git-ls-subdirs (string-append (assq-ref post 'sha1) ":comments") #f))) (define (post-sxml-n-comments post) `(div (@ (class "feedback")) diff --git a/tekuti/web.scm b/tekuti/web.scm index 278dd2f..6028ea3 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -38,6 +38,7 @@ (define *status-names* '((200 . "OK") (201 . "Created") + (304 . "Not Modified") (401 . "Unauthorized") (404 . "Not Found") (500 . "Internal Server Error"))) @@ -51,6 +52,7 @@ "\n")) +;; what the hell is this (define (request-output-headers request) (let-request request ((output-headers '()) (status 200) @@ -73,9 +75,10 @@ (define (finalize request) ;; update output headers ;; templatize body - (rpush* (rcons* request - 'sxml (templatize request) - 'doctype xhtml-doctype) + (rpush* (if (assq 'sxml request) + request + (rcons 'sxml (templatize request) + request)) 'output-headers (cons "Status" (status->string (rref request 'status 200))) 'output-headers @@ -98,6 +101,9 @@ ((GET archives year? month? day?) page-archives) ((GET archives year! month! day! post!) page-show-post) ((POST archives year! month! day! post!) page-new-comment) + ((GET feed) page-feed-rss2) + ((GET feed rss2) page-feed-rss2) + ((GET feed atom) page-feed-atom) ((GET tags) page-show-tags) ((GET tags tag!) page-show-tag) ((GET debug) page-debug) @@ -106,4 +112,4 @@ (define (handle-request request index) (let ((handler (choose-handler request))) - (pk (finalize (handler request index))))) + (finalize (handler (rcons 'doctype xhtml-doctype request) index)))) -- cgit v1.2.3-54-g00ecf