From a9141efbe695e2236e1e7e47e7b61b82c4b0ca4e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 29 Feb 2008 00:37:38 +0100 Subject: add missing files --- tekuti/index.scm | 101 ++++++++++++++++++++++++++++ tekuti/page-helpers.scm | 172 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 273 insertions(+) create mode 100644 tekuti/index.scm create mode 100644 tekuti/page-helpers.scm diff --git a/tekuti/index.scm b/tekuti/index.scm new file mode 100644 index 0000000..7524712 --- /dev/null +++ b/tekuti/index.scm @@ -0,0 +1,101 @@ +;; Tekuti +;; Copyright (C) 2008 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 +;; 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: +;; +;; Indexing of the persistent data store. +;; +;;; Code: + +(define-module (tekuti index) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (tekuti util) + #:use-module (tekuti git) + #:use-module (tekuti post) + #:use-module (tekuti tags) + #:export (maybe-reindex read-index)) + +(define index-specs + `((posts ,reindex-posts ,write ,read) + (tags ,reindex-tags ,write-hash ,read-hash))) + +(define (reindex oldindex master) + (with-backtrace + (with-time-debugging + (fold (lambda (pair index) + (acons (car pair) ((cadr pair) oldindex index) + index)) + (acons 'master master '()) + index-specs)))) + +(define (assoc-list-ref alist key n default) + (let ((l (assoc key alist))) + (if l (list-ref l n) default))) + +(define (index->blob key value) + (with-output-to-blob + ((assoc-list-ref index-specs key 2 write) value))) + +(define (blob->index name sha1) + (with-input-from-blob + sha1 + ((assoc-list-ref index-specs (string->symbol name) 3 read)))) + +(define (write-index index oldref) + (let ((new (git-commit-tree + (git-mktree + (pk (map (lambda (pair) + (list (car pair) + (index->blob (car pair) (cdr pair)) + 'blob)) + index))) + oldref "reindex\n" + (commit-utc-timestamp (assq-ref index 'master))))) + (or (false-if-git-error + (git "update-ref" "refs/heads/index" new (or oldref ""))) + (warn "could not update indexes ref")) + new)) + +(define (read-index) + (let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index"))) + (dents (if ref (git-ls-tree ref #f) '()))) + (cons ref + (and (and-map (lambda (spec) + (assoc (symbol->string (car spec)) dents)) + index-specs) + (map (lambda (dent) + (cons (string->symbol (car dent)) + (blob->index (car dent) (cadr dent)))) + dents))))) + +(define (maybe-reindex old-index) + (let ((master (git-rev-parse "refs/heads/master")) + (old-index-sha1 (and=> old-index car)) + (old-index-data (if old-index (cdr old-index) '()))) + (if (equal? (assq-ref old-index-data 'master) master) + old-index + (catch #t + (lambda () + (let ((new-index (reindex old-index-data master))) + (cons (write-index new-index old-index-sha1) + new-index))) + (lambda (key . args) + (warn "error while reindexing:" key args) + old-index))))) diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm new file mode 100644 index 0000000..57cabec --- /dev/null +++ b/tekuti/page-helpers.scm @@ -0,0 +1,172 @@ +;; Tekuti +;; Copyright (C) 2008 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 +;; 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: +;; +;; Helper bits, mostly verbose-like SXML stuff. +;; +;;; Code: + +(define-module (tekuti page-helpers) + #: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 (srfi srfi-19) + #:use-module (scheme kwargs) + #:export (relurl rellink + published-posts + post-editing-form + sidebar-ul main-sidebar tag-cloud + post-link admin-post-link + show-post + atom-header atom-entry)) + +(define (relurl path) + (string-append *public-url-base* path)) + +(define (rellink path . body) + `(a (@ (href ,(relurl path))) + ,@body)) + +(define (published-posts index n) + (filter-mapn (lambda (post) + (and (post-published? post) post)) + (assq-ref index 'posts) + n)) + +(define (post-editing-form post) + `(form (@ (method "POST") + (action ,(relurl (if post + (string-append "admin/modify-post/" + (url:encode (assq-ref post 'key))) + "admin/new-post")))) + (p "title: " + (input (@ (name "title") (type "text") + (value ,(if post (post-title post) ""))))) + (div (textarea (@ (name "body") (rows "20") (cols "80")) + ,(if post (post-raw-content post) ""))) + (input (@ (type "submit") + (value ,(if post "edit post" "new post")))))) + +(define (sidebar-ul body) + `(div (@ (id "menu")) + (ul ,@body))) + +;; double-encoding is a hack to trick apache +(define (admin-post-link post) + (rellink (string-append "admin/posts/" + (url:encode (post-key post))) + (assq-ref post 'title))) + +(define (post-link post) + (rellink (string-append "archives/" (url:decode (post-key post))) + (assq-ref post 'title))) + +(define (show-post post comments?) + `((h2 (@ (class "storytitle")) + ,(post-link post)) + (div (@ (class "post")) + (h3 (@ (class "meta")) + ,(post-readable-date post) + " (" ,@(list-intersperse (post-tag-links post) + " | ") + ")") + (div (@ (class "storycontent")) + ,(post-sxml-content post)) + ,@(if comments? '() + (list (post-sxml-n-comments post)))) + ,@(if comments? + (list (post-sxml-comments post)) + '()))) + +;; fixme: borks in the no-tags case +(define (tag-cloud index) + (define (determine-sizes counts) + (let ((maxcount (apply max counts))) + (map (lambda (x) + (floor (+ 80 (* 120 (/ x maxcount))))) + counts))) + (let* ((hash (assq-ref index 'tags)) + (cats (if hash + (hash-fold (lambda (k v seed) (acons k (length v) seed)) + '() hash) + '())) + (top-20 (dsu-sort (take-max (dsu-sort cats cdr >) 20) + car string>")) + ,(tag-cloud index))))) + +(define (atom-header server-name last-modified) + (define (relurl tail) + (string-append "http://" server-name *public-url-base* tail)) + `(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")))))) + +(define (atom-entry server-name post) + (define (relurl tail) + (string-append "http://" server-name *public-url-base* tail)) + `(entry + (author (name ,*name*) (uri ,(relurl ""))) + (title (@ (type "text")) ,(post-title post)) + (id ,(relurl (url:decode (post-key post)))) ;hack + (published ,(timestamp->atom-date (post-timestamp post))) + (updated ,(timestamp->atom-date (post-timestamp post))) + (content (@ (type "xhtml")) + (div (@ (xmlns "http://www.w3.org/1999/xhtml")) + ,(post-sxml-content post))))) -- cgit v1.2.3-54-g00ecf