aliens/tekuti
1
0
Fork 0
Code Activity

atom feed maybe working

Browse source
This commit is contained in:
Andy Wingo 2008-02-24 21:21:41 +01:00
parent 85b09abad7
commit caf9618312
7 changed files with 169 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

122
tekuti/comment.scm
View file

@ -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"))))))

6
tekuti/config.scm
View file

@ -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")

2
tekuti/git.scm
View file

@ -63,7 +63,7 @@
(string->list str))
(display #\'))))
(define *debug* #f)
(define *debug* #t)
(define (trc . args)
(if *debug*
(apply pk args)

18
tekuti/mod-lisp.scm
View file

@ -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")

78
tekuti/page.scm
View file

@ -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))))))))

2
tekuti/post.scm
View file

@ -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"))

14
tekuti/web.scm
View file

@ -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 @@
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\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))))