329 lines
13 KiB
Scheme
329 lines
13 KiB
Scheme
;; Tekuti
|
|
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 3 of
|
|
;; the License, or (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; if not, contact:
|
|
;;
|
|
;; Free Software Foundation Voice: +1-617-542-5942
|
|
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
|
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; This is the main script that will launch tekuti.
|
|
;;
|
|
;;; Code:
|
|
|
|
(define-module (tekuti page)
|
|
#:use-module (tekuti config)
|
|
#:use-module (tekuti util)
|
|
#:use-module (tekuti git)
|
|
#:use-module (tekuti post)
|
|
#:use-module (tekuti comment)
|
|
#:use-module (tekuti url)
|
|
#:use-module (tekuti request)
|
|
#:use-module (tekuti page-helpers)
|
|
#:use-module (srfi srfi-34)
|
|
#:use-module (srfi srfi-19)
|
|
#:use-module (scheme kwargs)
|
|
#:export (page-admin
|
|
page-admin-posts
|
|
page-admin-post
|
|
page-admin-new-post
|
|
page-admin-modify-post
|
|
page-admin-changes
|
|
page-admin-change
|
|
page-admin-revert-change
|
|
page-index
|
|
page-show-post
|
|
page-new-comment
|
|
page-archives
|
|
page-show-tags
|
|
page-show-tag
|
|
page-debug
|
|
page-search
|
|
page-feed-atom
|
|
page-debug
|
|
page-not-found))
|
|
|
|
(define (make-post-key . parts)
|
|
(url:encode (format #f "~{~a~^/~}" (map url:encode parts))))
|
|
|
|
(define (not-implemented request . args)
|
|
(rcons* request
|
|
'status 500
|
|
'body `((h1 "Not yet implemented")
|
|
(p "Path handler not yet implemented: "
|
|
,(rref request 'path-str)))))
|
|
|
|
(define (page-admin request index)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
;; here we need to be giving a dashboard view instead of this
|
|
(define (post-links n)
|
|
(mapn (lambda (post)
|
|
`(li ,(admin-post-link post)))
|
|
(assq-ref index 'posts)
|
|
n))
|
|
(define (recent-changes n)
|
|
(map (lambda (rev)
|
|
`(li ,(rellink (string-append "admin/changes/" (car rev))
|
|
(caddr rev))))
|
|
(git-rev-list "refs/heads/master" n)))
|
|
(rcons* request
|
|
'body `(,(sidebar-ul `((li (h2 "posts " ,(rellink "admin/posts" ">>"))
|
|
(ul ,@(post-links 5)))
|
|
(li (h2 "changes" ,(rellink "admin/changes" ">>"))
|
|
(ul ,(recent-changes 5)))))
|
|
(h2 "new post")
|
|
,(post-editing-form #f))))))
|
|
|
|
(define (page-admin-posts request index)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(define (post-headers)
|
|
(map (lambda (post)
|
|
`(h3 ,(admin-post-link post)))
|
|
(assq-ref index 'posts)))
|
|
(rcons* request
|
|
'body `((h1 "all your posts are belong to tekuti")
|
|
,@(post-headers))))))
|
|
|
|
(define (page-admin-post request index key)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(let ((post (post-from-key (assq-ref index 'master) key #t)))
|
|
(rcons* request
|
|
'body `((h1 ,(post-title post))
|
|
,(post-editing-form post)))))))
|
|
|
|
(define (page-admin-new-post request index)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(let ((post (make-new-post (request-form-data request))))
|
|
(rcons* (admin-post-redirect request post)
|
|
'body `((p "redirecting...")))))))
|
|
|
|
(define (page-admin-modify-post request index key)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(let ((post (modify-post key (request-form-data request))))
|
|
(rcons* (admin-post-redirect request post)
|
|
'body `((p "redirecting...")))))))
|
|
|
|
(define (page-admin-changes request index)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(let ((revs (git-rev-list (or (assoc-ref (rref request 'query '())
|
|
"start")
|
|
"refs/heads/master")
|
|
10)))
|
|
(rcons* request
|
|
'body `((h2 "recent changes")
|
|
,@(map (lambda (rev)
|
|
`(div (h3 ,(rellink (string-append "admin/changes/"
|
|
(car rev))
|
|
(caddr rev)))
|
|
,(timestamp->rfc822-date (cadr rev))))
|
|
revs)
|
|
(h3 ,(rellink (string-append "admin/changes/?start=" (caar (last-pair revs)))
|
|
"more" ))))))))
|
|
|
|
(define (page-admin-change request index sha1)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(let ((commit (parse-commit sha1)))
|
|
(rcons* request
|
|
'body `((h2 ,(assq-ref commit 'message))
|
|
(p "Committed on "
|
|
,(timestamp->rfc822-date
|
|
;; needlessly goes to git again...
|
|
(commit-utc-timestamp sha1)))
|
|
(pre ,(git "diff-tree" "-M" "-p" sha1))
|
|
(form (@ (action ,(relurl "admin/revert-change/" sha1))
|
|
(method "POST"))
|
|
(input (@ (type "submit") (value "Undo this change"))))))))))
|
|
|
|
|
|
(define (page-admin-revert-change request index sha1)
|
|
(with-authentication
|
|
request
|
|
(lambda ()
|
|
(let ((new-master (git-revert "refs/heads/master" sha1)))
|
|
(rcons* (redirect request (relurl "admin"))
|
|
'body `((h3 "Change reverted")))))))
|
|
|
|
(define (page-index request index)
|
|
(rcons* request
|
|
'body `(,(main-sidebar request index)
|
|
,@(map (lambda (post)
|
|
(show-post post #f))
|
|
(published-posts index 10)))))
|
|
|
|
(define (page-show-post request index year month day post)
|
|
(cond
|
|
((post-from-key (assq-ref index 'master)
|
|
(make-post-key year month day post))
|
|
=> (lambda (post)
|
|
(rcons* request
|
|
'title (string-append (post-title post) " -- " *title*)
|
|
'body `(,(post-sidebar post index)
|
|
,(show-post post #t)))))
|
|
(else
|
|
(page-not-found request index))))
|
|
|
|
(define (page-new-comment request index year month day name)
|
|
(let ((data (request-form-data request)))
|
|
(cond
|
|
((post-from-key (assq-ref index 'master)
|
|
(make-post-key year month day name))
|
|
=> (lambda (post)
|
|
(cond
|
|
((bad-new-comment-post? data)
|
|
=> (lambda (reason)
|
|
(rcons* request
|
|
'body `((p "Bad post data: " ,(pk reason))))))
|
|
(else
|
|
(let ((comment (make-new-comment (post-key post) (post-title post)
|
|
data)))
|
|
;; nb: at this point, `post' is out-of-date
|
|
(rcons* (redirect request (post-url post "#comments"))
|
|
'title "comment posted"
|
|
'body `((p "Comment posted, thanks."))))))))
|
|
(else
|
|
(page-not-found request index)))))
|
|
|
|
;; 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 (published-posts index -1)))
|
|
(cond ((or (null? posts) (too-early? (car posts)))
|
|
(rcons* request
|
|
'title *title*
|
|
'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 (string-append "archives -- " *title*)
|
|
'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-search request index)
|
|
(let* ((string (or (assoc-ref (request-form-data request) "string") ""))
|
|
(posts (find-posts-matching string index)))
|
|
(rcons* request
|
|
'body `((h2 "search results: \"" ,string "\"")
|
|
,@(if (null? posts)
|
|
`((p "No posts matched your search string."))
|
|
(map (lambda (post)
|
|
`(p ,(post-link post)))
|
|
posts))))))
|
|
|
|
(define (page-show-tags request index)
|
|
(rcons* request
|
|
'title (string-append "all tags -- " *title*)
|
|
'body `((div (@ (id "tag-cloud"))
|
|
(h2 "all tags")
|
|
,@(tag-cloud (top-tags index 200))))))
|
|
|
|
(define (page-show-tag request index tag)
|
|
(let* ((tags (assq-ref index 'tags))
|
|
(posts (map (lambda (key)
|
|
(post-from-key (assq-ref index 'master) key))
|
|
(hash-ref tags tag '()))))
|
|
(if (pair? posts)
|
|
(rcons* request
|
|
'title (string-append "posts tagged \"" tag "\"")
|
|
'body `((h2 "posts tagged \"" ,tag "\"")
|
|
,@(map (lambda (post) `(p ,(post-link post)))
|
|
posts)
|
|
,(related-tag-cloud tag index)))
|
|
(rcons* request
|
|
'status 404
|
|
'body `((h2 "Unknown tag " ,tag)
|
|
(p "No posts were found tagged as \"" ,tag "\"."))))))
|
|
|
|
(define (page-debug request index)
|
|
(rcons* request
|
|
'title "debug"
|
|
'body `((p "hello world!")
|
|
(table
|
|
(tr (th "header") (th "value"))
|
|
,@(map (lambda (pair)
|
|
`(tr (td ,(car pair)) (td ,(cdr pair))))
|
|
(rref request 'headers))))))
|
|
|
|
(define (page-not-found request index)
|
|
(rcons* (pk 'not-found request)
|
|
'status 404
|
|
'body `((h1 "Page not found")
|
|
(p "Unknown path: " ,(rref request 'path-str)))))
|
|
|
|
(define (page-feed-atom request index)
|
|
(let ((last-modified (let ((posts (published-posts index 1)))
|
|
(and (pair? posts)
|
|
(post-timestamp (car posts)))))
|
|
(server-name (request-server-name request)))
|
|
(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* (if last-modified
|
|
(rpush 'output-headers (cons "Last-Modified"
|
|
(timestamp->rfc822-date
|
|
last-modified))
|
|
request)
|
|
request)
|
|
'doctype ""
|
|
'content-type "application/atom+xml"
|
|
'sxml (append (atom-header server-name last-modified)
|
|
(map
|
|
(lambda (post)
|
|
(atom-entry server-name post))
|
|
(published-posts index 10))))))))
|