From 77509e4d3fabf60b11a17972ec8276d8cc119811 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Feb 2008 18:20:41 +0100 Subject: basic archives done --- tekuti/comment.scm | 23 +++++++++++++-- tekuti/git.scm | 8 ++++-- tekuti/page.scm | 84 +++++++++++++++++++++++++++++++++++++++++++++++++++--- tekuti/post.scm | 69 ++++++++++++++++++++++++++++++++++++++------ tekuti/web.scm | 2 ++ 5 files changed, 169 insertions(+), 17 deletions(-) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index f0deb43..7941434 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -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)) diff --git a/tekuti/git.scm b/tekuti/git.scm index 5c516fa..4d5e08f 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -135,9 +135,11 @@ (list name object type mode))) (define (git-ls-subdirs treeish path) - (match-lines (git "ls-tree" treeish (or path ".")) - "^(.+) tree (.+)\t(.+)$" (_ mode object name) - (cons name object))) + (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 diff --git a/tekuti/page.scm b/tekuti/page.scm index cbc2696..ff23f68 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -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 diff --git a/tekuti/post.scm b/tekuti/post.scm index a1b7531..43e19c9 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -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))) diff --git a/tekuti/web.scm b/tekuti/web.scm index f958ba6..8d87fcc 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -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))) -- cgit v1.2.3-54-g00ecf