diff --git a/tekuti/index.scm b/tekuti/index.scm index 37c1eb2..1cd2d37 100644 --- a/tekuti/index.scm +++ b/tekuti/index.scm @@ -35,7 +35,8 @@ #:export (maybe-reindex read-index update-index)) (define index-specs - `((posts ,reindex-posts ,write ,read) + `((posts ,reindex-posts ,write-hash ,read-hash) + (posts-by-date ,reindex-posts-by-date ,write ,read) (tags ,reindex-tags ,write-hash ,read-hash) (cache ,(lambda _ (make-empty-cache)) ,(lambda (x) #f) ,(lambda () '())))) diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm index eb946a1..4b4c7ff 100644 --- a/tekuti/page-helpers.scm +++ b/tekuti/page-helpers.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008, 2010 Andy Wingo +;; Copyright (C) 2008, 2010, 2012 Andy Wingo ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -41,7 +41,6 @@ #:export (respond relurl rellink post-url - published-posts post-editing-form sidebar-ul top-tags tag-cloud main-sidebar post-sidebar related-tag-cloud @@ -151,12 +150,6 @@ (relative-path-link *public-path-base* path-components text #:query query #:fragment fragment)) -(define (published-posts index n) - (filter-mapn (lambda (post) - (and (post-published? post) post)) - (assq-ref index 'posts) - n)) - (define (post-editing-form post) `(div (form (@ (method "POST") @@ -371,7 +364,7 @@ (git "grep" "-l" "-F" string master "--" "*/content")) "") ":(.+)/content$" (_ key) - (post-from-key master key))) + (post-from-key index key))) post-timestamp >))) diff --git a/tekuti/page.scm b/tekuti/page.scm index 32d81bd..0fac648 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008, 2010, 2011 Andy Wingo +;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -75,10 +75,9 @@ (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)) + (map (lambda (post) + `(li ,(admin-post-link post))) + (latest-posts index #:allow-unpublished? #t #:limit n))) (define (recent-changes n) (map (lambda (rev) `(li ,(rellink `("admin" "changes" ,(car rev)) @@ -100,7 +99,7 @@ (define (post-headers) (map (lambda (post) `(h3 ,(admin-post-link post))) - (assq-ref index 'posts))) + (latest-posts index #:allow-unpublished? #t #:limit -1))) (respond `((h1 "all your posts are belong to tekuti") ,@(post-headers)))))) @@ -108,7 +107,7 @@ (with-authentication request (lambda () - (let ((post (post-from-key (assq-ref index 'master) key #t))) + (let ((post (post-from-key index key #:allow-unpublished? #t))) (respond `((h1 ,(post-title post)) ,(post-editing-form post))))))) @@ -132,14 +131,14 @@ (with-authentication request (lambda () - (delete-post key) + (delete-post (post-from-key index key #:allow-unpublished? #t)) (respond `((p "redirecting...")) #:redirect (relurl `("admin")))))) (define (page-admin-delete-comment request body index key comment-id) (with-authentication request (lambda () - (let ((post (post-from-key (assq-ref index 'master) key #t))) + (let ((post (post-from-key index key #:allow-unpublished? #t))) (delete-comment post comment-id) (respond `((p "redirecting...")) #:redirect (admin-post-url post)))))) @@ -189,13 +188,12 @@ (respond `(,(main-sidebar request index) ,@(map (lambda (post) (show-post post #f)) - (published-posts index 10))) + (latest-posts index #:limit 10))) #:etag (assq-ref index 'master))) (define (page-show-post request body index year month day post) (cond - ((post-from-key (assq-ref index 'master) - (make-post-key year month day post)) + ((post-from-key index (make-post-key year month day post)) => (lambda (post) (respond `(,(post-sidebar post index) ,(show-post post #t)) @@ -207,8 +205,7 @@ (define (page-new-comment request body index year month day name) (let ((data (request-form-data request body))) (cond - ((post-from-key (assq-ref index 'master) - (make-post-key year month day name)) + ((post-from-key index (make-post-key year month day name)) => (lambda (post) (cond ((bad-new-comment-post? data) @@ -243,7 +240,7 @@ (define (make-date-header post) (lambda (x) #f)) - (let lp ((posts (published-posts index -1))) + (let lp ((posts (latest-posts index #:limit -1))) (cond ((or (null? posts) (too-early? (car posts))) (respond `((h1 "No posts found") (p "No posts were found in the specified period.")) @@ -283,7 +280,7 @@ (define (page-show-tag request body index tag) (let* ((tags (assq-ref index 'tags)) (posts (map (lambda (key) - (post-from-key (assq-ref index 'master) key)) + (post-from-key index key)) (hash-ref tags tag '())))) (if (pair? posts) (respond `((h2 "posts tagged \"" ,tag "\" (" @@ -343,9 +340,7 @@ (define (page-feed-atom request body index) (let ((with (request-query-ref-all request "with")) (without (request-query-ref-all request "without")) - (tags (assq-ref index 'tags)) - (posts (assq-ref index 'posts)) - (master (assq-ref index 'master))) + (tags (assq-ref index 'tags))) (define include? (if (pair? with) (fold (lambda (tag cont) @@ -369,9 +364,8 @@ (atom-feed-from-posts request body index - (filter-mapn (lambda (post) - (and (include? post) (not (exclude? post)) - (post-published? post) - post)) - posts - 10)))) + (latest-posts index + #:filter + (lambda (post) + (and (include? post) (not (exclude? post)))) + #:limit 10)))) diff --git a/tekuti/post.scm b/tekuti/post.scm index 939afe6..2198b6c 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008, 2010, 2011 Andy Wingo +;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -35,7 +35,7 @@ #:use-module (tekuti filters) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) - #:export (post-from-tree post-from-key + #:export (post-from-key post-tags post-timestamp post-key post-published? post-comments-open? post-comments @@ -44,14 +44,14 @@ post-title make-new-post modify-post delete-post - - all-published-posts - reindex-posts)) + latest-posts -;;; + reindex-posts reindex-posts-by-date)) + +;;; ;;; pulling posts out of git -;;; +;;; (define *post-spec* `((timestamp . ,string->number) @@ -69,15 +69,21 @@ identity))) (cons k (parse v)))))) -(define (post-from-key master key . allow-unpublished) +(define (post-from-git master key) (false-if-git-error (let ((pairs (git-ls-subdirs master key))) (and (= (length pairs) 1) - (let ((post (post-from-tree key (cdar pairs)))) - (if (or (post-published? post) - (and (pair? allow-unpublished) (car allow-unpublished))) - post - #f)))))) + (post-from-tree key (cdar pairs)))))) + +;;; +;;; pulling posts out of the index +;;; + +(define* (post-from-key index key #:key allow-unpublished?) + (let ((post (hash-ref (assq-ref index 'posts) key))) + (if (and post (or (post-published? post) allow-unpublished?)) + post + #f))) ;;; ;;; accessors @@ -156,13 +162,13 @@ (maybe-clear `((create (,key) ("metadata" ,metadata blob)) (create (,key) ("content" ,content blob))))))) - (post-from-key + (post-from-git (git-update-ref "refs/heads/master" (lambda (master) (git-commit-tree (munge-tree master ops) master message #f)) 5) - key #t)))) + key)))) (define space-to-dash (s///g "[ .]" "-")) (define remove-extraneous (s///g "[^a-z0-9-]+" "")) @@ -201,41 +207,45 @@ (define (modify-post old-key post-data) (munge-post old-key (parse-post-data post-data))) -(define (delete-post key) - (let* ((post (post-from-key "refs/heads/master" key)) - (message (format #f "~a: \"~a\"" "post deleted" (post-title post)))) +(define (delete-post post) + (let ((message (format #f "~a: \"~a\"" "post deleted" (post-title post)))) (git-update-ref "refs/heads/master" (lambda (master) - (git-commit-tree (munge-tree1 master 'delete '() `(,key)) - master message #f)) + (git-commit-tree + (munge-tree1 master 'delete '() `(,(post-key post))) + master message #f)) 5))) -(define (all-posts master) - (map (lambda (pair) - (post-from-tree (car pair) (cdr pair))) - (git-ls-subdirs master #f))) +(define* (latest-posts index #:key allow-unpublished? (filter identity) + (limit 10)) + (filter-mapn + (lambda (key) + (and=> (post-from-key index key #:allow-unpublished? allow-unpublished?) + (lambda (post) (and post (filter post) post)))) + (assq-ref index 'posts-by-date) + limit)) -(define (all-published-posts master) - (dsu-sort - (filter post-published? (all-posts master)) - post-timestamp - >)) - -(define (hash-fill proc list) - (let ((table (make-hash-table))) - (for-each (lambda (x) (proc x table)) - list) - table)) - -(define (reindex-posts oldindex newindex) - (let ((old (hash-fill (lambda (post h) - (hash-set! h (assq-ref post 'sha1) post)) - (or (assq-ref oldindex 'posts) '())))) - (dsu-sort (map (lambda (dent) - (or (hash-ref old (cadr dent)) - (begin (pk 'updated dent) - (post-from-tree (car dent) (cadr dent))))) - (git-ls-tree (assq-ref newindex 'master) #f)) - post-timestamp - >))) +(define (reindex-posts old-index index) + (let ((old (assq-ref old-index 'posts)) + (new (make-hash-table))) + (for-each + (lambda (dent) + (let* ((key (car dent)) + (sha1 (cadr dent)) + (prev (and (hash-table? old) (hash-ref old key)))) + (hash-set! new key + (if (and prev (equal? (assq-ref prev 'sha1) sha1)) + prev + (begin + (pk 'updated dent) + (post-from-tree key sha1)))))) + (git-ls-tree (assq-ref index 'master) #f)) + new)) +(define (reindex-posts-by-date old-index index) + (map cdr + (sort (hash-map->list (lambda (key post) + (cons (post-timestamp post) key)) + (assq-ref index 'posts)) + (lambda (x y) + (> (car x) (car y)))))) diff --git a/tekuti/tags.scm b/tekuti/tags.scm index 04c1c42..55bea42 100644 --- a/tekuti/tags.scm +++ b/tekuti/tags.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008, 2010 Andy Wingo +;; Copyright (C) 2008, 2010, 2012 Andy Wingo ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -54,8 +54,7 @@ hash)) (define (compute-related-posts post index) - (let ((hash (assq-ref index 'tags)) - (master (assq-ref index 'master))) + (let ((hash (assq-ref index 'tags))) (if hash (let ((accum (make-hash-table))) (for-each @@ -69,7 +68,7 @@ (dsu-sort (dsu-sort (hash-fold (lambda (key tags rest) - (acons (post-from-key master key) tags rest)) + (acons (post-from-key index key) tags rest)) '() accum) (lambda (x) (post-timestamp (car x))) >) @@ -77,8 +76,7 @@ '()))) (define (compute-related-tags tag index) - (let ((hash (assq-ref index 'tags)) - (master (assq-ref index 'master))) + (let ((hash (assq-ref index 'tags))) (if hash (let ((accum (make-hash-table))) (for-each @@ -87,7 +85,7 @@ (lambda (other-tag) (if (not (equal? other-tag tag)) (hash-push! accum other-tag key))) - (post-tags (post-from-key master key)))) + (post-tags (post-from-key index key)))) (or (hash-ref hash tag) '())) (dsu-sort (hash-fold @@ -99,4 +97,4 @@ '()))) (define (reindex-tags old-index index) - (compute-tags (filter post-published? (assq-ref index 'posts)))) + (compute-tags (latest-posts index #:limit -1)))