aliens/tekuti
1
0
Fork 0
Code Activity

basic archives done

Browse source
This commit is contained in:
Andy Wingo 2008-02-22 18:20:41 +01:00
parent ca585c382f
commit 77509e4d3f
5 changed files with 169 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
tekuti/comment.scm
View file

@ -28,8 +28,10 @@
(define-module (tekuti comment)
#:use-module (tekuti git)
#:use-module (tekuti util)
#:use-module (tekuti filters)
#:use-module (srfi srfi-1)
#:export (comment-from-tree build-comment-skeleton))
#:use-module (srfi srfi-19)
#:export (comment-from-tree comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date))
(use-modules (ice-9 rdelim)
(ice-9 popen)
@ -43,7 +45,24 @@
`((timestamp . ,string->number)))
(define (comment-from-tree encoded-name sha1)
(acons 'encoded-name encoded-name
(parse-metadata (string-append sha1 ":" "metadata") *comment-spec*)))
(acons 'sha1 sha1
(parse-metadata (string-append sha1 ":" "metadata")
*comment-spec*))))
(define (comment-readable-date comment)
(let ((date (time-utc->date
(make-time time-utc 0 (assq-ref comment 'timestamp)))))
(date->string date "~e ~B ~Y ~l:~M ~p")))
(define (comment-raw-content comment)
(git "show" (string-append (assq-ref comment 'sha1) ":content")))
(define (comment-sxml-content comment)
(let ((format (or (assq-ref comment 'format) 'wordpress)))
((case format
((wordpress) wordpress->sxml)
(else (lambda (text) `(pre ,text))))
(comment-raw-content comment))))
(define (comment-timestamp comment-alist)
(or (assq-ref comment-alist 'timestamp) #f))

2
tekuti/git.scm
View file

@ -135,9 +135,11 @@
(list name object type mode)))
(define (git-ls-subdirs treeish path)
(or (false-if-git-error
(match-lines (git "ls-tree" treeish (or path "."))
"^(.+) tree (.+)\t(.+)$" (_ mode object name)
(cons name object)))
'()))
(define (parse-metadata treeish specs)
(filter

84
tekuti/page.scm
View file

@ -32,6 +32,8 @@
#:use-module (tekuti url)
#:use-module (tekuti request)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-19)
#:use-module (scheme kwargs)
#:export (page-admin
page-admin-posts
page-admin-post
@ -43,6 +45,8 @@
page-index
page-show-post
page-archives
page-show-tags
page-show-tag
page-debug
page-search
page-show-post
@ -155,7 +159,7 @@
(p "Created new post: " ,(assoc-ref form-data "title"))
(pre ,(assoc-ref form-data "body"))))))
(define (show-post post)
(define (show-post post comments?)
`((h2 (@ (class "storytitle"))
,(post-link post))
(div (@ (class "post"))
@ -165,7 +169,10 @@
" | ")
")")
(div (@ (class "storycontent"))
,(post-sxml-content post)))))
,(post-sxml-content post)))
,(if comments?
(post-sxml-comments post)
(post-sxml-n-comments post))))
;; (a (@ (href ,new-url)) ,new-url)
@ -186,11 +193,80 @@
(pk post)
(rcons* request
'title (assq-ref post 'title)
'body (show-post post)))))
'body (show-post post #t)))))
(else
(page-not-found request index)))))
(define page-archives not-implemented)
(define/kwargs (date-increment date (day 0) (month 0) (year 0))
(make-date (date-nanosecond date) (date-second date)
(date-minute date) (date-minute date)
(+ (date-day date) day) (+ (date-month date) month)
(+ (date-year date) year) (date-zone-offset date)))
(define (date-comparator date comp)
(let ((this (time-second (date->time-utc date))))
(lambda (that)
(comp that this))))
(define (date-before? date)
(date-comparator date <))
(define (date-after? date)
(date-comparator date >))
(define (compose1 proc . procs)
(if (null? procs)
proc
(let ((other (apply compose1 procs)))
(lambda (x)
(proc (other x))))))
;; fixme exception handling for input
(define (page-archives request index year month day)
(let ((year (and=> year string->number))
(month (and=> month string->number))
(day (and=> day string->number)))
(let ((start (make-date 0 0 0 0 (or day 1) (or month 1) (or year 1980) 0)))
(define too-early?
(compose1 (date-before? start) post-timestamp))
(define early-enough?
(if year
(compose1 (date-before?
(cond (day (date-increment start #:day 1))
(month (date-increment start #:month 1))
(else (date-increment start #:year 1))))
post-timestamp)
(lambda (post) #t)))
(define (make-date-header post)
(lambda (x) #f))
(let lp ((posts (assq-ref index 'posts)))
(pk 'foo (or (null? posts) (car posts)))
(cond ((or (null? posts) (too-early? (car posts)))
(rcons* request
'title "no posts found"
'body `((h1 "No posts found")
(p "No posts were found in the specified period."))))
((early-enough? (car posts))
(let lp ((posts posts) (new-header (make-date-header #t)) (out '()))
(cond
((or (null? posts) (too-early? (car posts)))
(rcons* request
'title "archives"
'body (reverse out)))
((new-header (car posts))
=> (lambda (sxml)
(lp (cdr posts) (make-date-header (car posts))
(cons (post-link (car posts)) (append sxml out)))))
(else
(lp (cdr posts) new-header (cons `(p ,(post-link (car posts))) out))))))
(else (lp (cdr posts))))))))
(define (page-show-tags request index)
(not-implemented request index))
(define (page-show-tag request index tag)
(not-implemented request index))
(define (page-debug request index)
(rcons* request

69
tekuti/post.scm
View file

@ -28,14 +28,19 @@
#:use-module (srfi srfi-1)
#:use-module (match-bind)
#:use-module (tekuti util)
#:use-module (tekuti url)
#:use-module (tekuti comment)
#:use-module (tekuti config)
#:use-module (tekuti git)
#:use-module (tekuti filters)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:export (reindex-posts post-from-tree post-from-key post-categories
post-timestamp
post-sxml-content post-raw-content all-published-posts
post-readable-date post-category-links))
post-readable-date post-category-links post-sxml-n-comments
post-sxml-comments))
;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
@ -54,14 +59,14 @@
(categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))
(title . ,identity)))
(define-memoized (post-from-tree encoded-name sha1)
(define (post-from-tree encoded-name sha1)
(acons 'key encoded-name
(acons 'content-ref (string-append sha1 ":content")
(acons 'sha1 sha1
(parse-metadata (string-append sha1 ":metadata")
*post-spec*))))
(define (post-raw-content post)
(git "show" (assq-ref post 'content-ref)))
(git "show" (string-append (assq-ref post 'sha1) ":content")))
(define (post-sxml-content post)
(let ((format (or (assq-ref post 'format) 'wordpress)))
@ -76,7 +81,11 @@
(date->string date "~e ~B ~Y ~l:~M ~p")))
(define (post-category-links post)
(post-categories post))
(map (lambda (cat)
`(a (@ (href ,(string-append *public-url-base* "tags/"
(url:encode cat))))
,cat))
(post-categories post)))
(define (post-from-key master key)
(let ((pairs (git-ls-subdirs master key)))
@ -92,15 +101,59 @@
(dsu-sort
(filter post-published? (all-posts master))
post-timestamp
<))
>))
(define (post-comments sha1)
(define (post-comments post)
(dsu-sort
(map (lambda (pair)
(comment-from-tree (car pair) (cdr pair)))
(git-ls-subdirs sha1 "comments/"))
(git-ls-subdirs (assq-ref post 'sha1) "comments/"))
comment-timestamp
<))
(define (post-sxml-comments post)
(let ((comments (post-comments post))
(comment-status (assq-ref post 'comment_status)))
(define (n-comments-header)
(and (or (not (null? comments)) (equal? comment-status "open"))
`(h3 (@ (id "comments"))
,(let ((len (length comments)))
(case len
((0) "No responses")
((1) "One response")
(else (format #f "~d responses" len)))))))
(define (show-comment comment)
`(li (@ (class "alt") (id ,(assq-ref comment 'encoded-name)))
(cite ,(let ((url (assq-ref comment 'author_url))
(name (assq-ref comment 'author)))
(if url
`(a (@ (href ,url) (rel "external nofollow")) ,name)
name)))
" says:" (br)
(small (@ (class "commentmetadata"))
(a (@ (href ,(string-append
"#" (assq-ref comment 'encoded-name))))
,(comment-readable-date comment)))
,(comment-sxml-content comment)))
`(div
,@(or (and=> (n-comments-header) list) '())
,@(let ((l (map show-comment comments)))
(if (null? l) l
`((ol (@ (class "commentlist")) ,@l))))
,(if (equal? comment-status "closed")
`(p (@ (id "nocomments")) "Comments are closed.")
'(div (h3 "Leave a Reply")
"...")))))
(define (post-n-comments post)
(length (git-ls-subdirs (assq-ref post 'sha1) "comments/")))
(define (post-sxml-n-comments post)
`(div (@ (class "feedback"))
(a (@ (href ,(string-append *public-url-base* "/archives/"
(assq-ref post 'encoded-name)
"#comments")))
"(" ,(post-n-comments post) ")")))
(define (reindex-posts index)
(all-published-posts (assq-ref index 'master)))

2
tekuti/web.scm
View file

@ -97,6 +97,8 @@
((GET) page-index)
((GET archives year? month? day?) page-archives)
((GET archives year! month! day! post!) page-show-post)
((GET tags) page-show-tags)
((GET tags tag!) page-show-tag)
((GET debug) page-debug)
((POST search) page-search)
(else page-not-found)))