From 436ef221345ca074ff82115e359c9a85b5c70b1a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 Feb 2008 14:28:38 +0100 Subject: continuing simplification work --- tekuti/boot.scm | 8 ++--- tekuti/categories.scm | 45 -------------------------- tekuti/comment.scm | 8 ++--- tekuti/git.scm | 79 ++++++++++++--------------------------------- tekuti/mod-lisp.scm | 88 ++++++--------------------------------------------- tekuti/page.scm | 24 ++++++++++---- tekuti/post.scm | 31 ++++++++++-------- tekuti/tags.scm | 52 ++++++++++++++++++++++++++++++ tekuti/util.scm | 35 ++++++++++++++++++-- tekuti/web.scm | 14 +++++--- 10 files changed, 167 insertions(+), 217 deletions(-) delete mode 100644 tekuti/categories.scm create mode 100644 tekuti/tags.scm diff --git a/tekuti/boot.scm b/tekuti/boot.scm index 13e8e82..8f94fe6 100644 --- a/tekuti/boot.scm +++ b/tekuti/boot.scm @@ -1,7 +1,3 @@ -#! /bin/bash -# -*- scheme -*- -exec guile $GUILE_FLAGS -l $0 -e main -- "$@" -!# ;; Tekuti ;; Copyright (C) 2008 Andy Wingo @@ -24,7 +20,7 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@" ;;; Commentary: ;; -;; This is the main script that will launch tekuti. +;; Module to parse options, etc before dropping into the main loop. ;; ;;; Code: @@ -77,7 +73,7 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@" (let ((run-utility (@ (ice-9 gds-client) run-utility))) (make-thread (lambda () - (with-backtrace run-utility))))) + (with-backtrace (run-utility)))))) opts)) (define (boot args) diff --git a/tekuti/categories.scm b/tekuti/categories.scm deleted file mode 100644 index daee4be..0000000 --- a/tekuti/categories.scm +++ /dev/null @@ -1,45 +0,0 @@ -;; 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: -;; -;; This is the main script that will launch tekuti. -;; -;;; Code: - -(define-module (tekuti categories) - #:use-module (tekuti util) - #:use-module (tekuti post) - #:use-module (tekuti git) - #:export (reindex-categories)) - -(define (compute-categories posts) - (let ((hash (make-hash-table))) - (for-each - (lambda (post) - (for-each - (lambda (cat) - (hash-push! hash cat (assq-ref post 'key))) - (post-categories post))) - posts) - hash)) - -(define (reindex-categories old-index index) - (compute-categories (assq-ref index 'posts))) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index 0998284..ee42d3a 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -221,7 +221,7 @@ (assert-referenced-files-present (append (map cdr lremove) (map caar lchange)) dents) ; (trc 'make-tree-deep treeish add remove change) - (make-tree-full + (git-mktree (append (map cdr ladd) (filter-map @@ -231,7 +231,7 @@ #f) ((member (car dent) (map cadr lchange)) (cdr lchange)) - ((and (equal? (caddr dent) "tree") + ((and (eq? (caddr dent) 'tree) (member (car dent) (map caar (append dadd dremove dchange)))) (let ((level-down (lambda (x) @@ -243,11 +243,11 @@ (filter-map level-down dadd) (filter-map level-down dremove) (filter-map level-down dchange)) - "tree" "040000"))) + 'tree))) (else dent))) (append (filter-map (lambda (x) (and (not (assoc (caar x) dents)) - (list (caar x) #f "tree" #f))) + (list (caar x) #f 'tree))) dadd) dents)))))) diff --git a/tekuti/git.scm b/tekuti/git.scm index 355d3b1..f6e45cb 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -38,8 +38,9 @@ git git* ensure-git-repo git-ls-tree git-ls-subdirs parse-metadata parse-commit commit-utc-timestamp - commit-parents make-tree git-rev-parse make-tree-full + commit-parents git-mktree git-rev-parse create-blob git-update-ref + git-commit-tree write-indices read-indices)) @@ -135,7 +136,7 @@ (match-lines (git "ls-tree" treeish (or path ".")) "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name) ;; reversed for assoc - (list name object type mode))) + (list name object (string->symbol type)))) '())) (define (git-ls-subdirs treeish path) @@ -184,13 +185,17 @@ (lambda (x) (eq? (car x) 'parent)) (parse-commit commit)))) -(define (make-tree alist) +(define (git-mktree alist) (string-trim-both (git* '("mktree") #:input (string-join - (map (lambda (pair) - (let ((name (car pair)) (sha (cdr pair))) - (format #f "040000 tree ~a\t~a" sha name))) + (map (lambda (l) + (format #f + (if (or (null? (cddr l)) + (equal? (caddr l) 'blob)) + "100644 blob ~a\t~a" + "040000 tree ~a\t~a") + (cadr l) (car l))) alist) "\n" 'suffix)))) @@ -201,17 +206,6 @@ (string-trim-both (git* '("hash-object" "-w" "--stdin") #:input contents))) -;; order: name object type mode -(define (make-tree-full alist) - (string-trim-both - (git* '("mktree") - #:input (string-join - (map (lambda (l) - (apply format #f "~a ~a ~a\t~a" - (reverse l))) - alist) - "\n" 'suffix)))) - (define (git-update-ref refname proc count) (let* ((ref (git-rev-parse refname)) (commit (proc ref))) @@ -225,46 +219,15 @@ (pk "failed to update the ref, trying again..." refname) (git-update-ref (git-rev-parse refname) (1- count)))))) -;; fixme: map-pairs - -(define (assoc-list-ref alist key n default) - (let ((l (assoc key alist))) - (if l (list-ref l n) default))) - -(define (write-indices indices oldref specs) - (let* ((master (assq-ref indices 'master)) - (ts (commit-utc-timestamp master)) - (env (list "GIT_COMMMITTER=tekuti" - (format #f "GIT_COMMITTER_DATE=~a +0100" ts) - (format #f "GIT_AUTHOR_DATE=~a +0100" ts))) - (tree (make-tree-full - (map (lambda (pair) - (list (symbol->string (car pair)) - (create-blob - (with-output-to-string - (lambda () - ((assoc-list-ref specs (car pair) 2 write) - (cdr pair))))) - "blob" "100644")) - indices)))) - (let ((new (string-trim-both - (git* (cons* "commit-tree" tree - (if oldref (list "-p" oldref) '())) - #:input "reindex\n" #:env env)))) - (or (false-if-git-error - (git "update-ref" "refs/heads/index" new (or oldref ""))) - (warn "could not update indexes ref")) - new))) +(define (git-commit-tree tree parent message timestamp) + (string-trim-both + (git* (cons* "commit-tree" tree + (if parent (list "-p" parent) '())) + #:input message + #:env (if timestamp + (list "GIT_COMMMITTER=tekuti" + (format #f "GIT_COMMITTER_DATE=~a +0100" timestamp) + (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp)))))) -(define (read-indices specs) - (and=> (false-if-git-error (git-rev-parse "refs/heads/index")) - (lambda (ref) - (cons ref - (map (lambda (dent) - (cons (string->symbol (car dent)) - (with-input-from-string - (git "show" (cadr dent)) - (assoc-list-ref specs (string->symbol (car dent)) 3 read)))) - (git-ls-tree (assq-ref (parse-commit ref) 'tree) - #f)))))) +;; fixme: map-pairs diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index eb23689..266350c 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -26,20 +26,12 @@ (define-module (tekuti mod-lisp) #:use-module (ice-9 rdelim) - #:use-module (ice-9 receive) - #:use-module (ice-9 stack-catch) #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module (sxml simple) - #:use-module (sxml transform) #:use-module (tekuti config) #:use-module (tekuti util) - #:use-module (tekuti git) ; rev-parse + #:use-module (tekuti index) ; rev-parse #:use-module (tekuti request) #:use-module (tekuti web) - - ;; these for their reindex methods - #:use-module (tekuti post) - #:use-module (tekuti categories) #:export (event-loop)) ;;; thought: ignore SIGPIPE, otherwise apache dying will kill us @@ -69,23 +61,13 @@ (display "end\n" port)) (define (write-body request socket) - (let ((sxml (rref request 'sxml #f))) - (if sxml - (begin (display (rref request 'doctype "") socket) - (sxml->xml sxml socket)) - (display "" socket)))) + ((rref request 'output error) socket)) (define (request-output-headers request) - (let ((rheads '(("Content-Type" . output-type)))) - (map (lambda (h) - (cons (car h) - (or (and=> (assoc-ref (car h) rheads) - (lambda (k) (rref request k #f))) - (cdr h)))) - (rref request 'output-headers '())))) + (rref request 'output-headers '())) (define (connection-received socket sockaddr index) - (let* ((headers (pk (read-headers socket))) + (let* ((headers (read-headers socket)) (post-data (read-chars (string->number (or (assoc-ref headers "content-length") "0")) @@ -102,9 +84,11 @@ (write-headers '(("Status" . "500 Internal Server Error") ("Content-Type" . "text/plain")) socket) - (write args socket) - (newline) - (with-output-to-port socket backtrace)) + (display "Sorry bub, had an error. Please let the admin know. Thanks!\n" + socket) + (write headers) (newline) + (write args) (newline) + (backtrace)) (lambda args (fluid-set! the-last-stack (make-stack #t 2 0)) (apply throw args))) @@ -121,58 +105,6 @@ (proc socket) (shutdown socket 2)))) -(define (with-time-debugging proc) - (let ((start (gettimeofday))) - (pk 'start-clock) - (let ((val (proc))) - (let ((stop (gettimeofday))) - (pk 'stop-clock (+ (- (car stop) (car start)) - (* 1e-6 (- (cdr stop) (cdr start))))) - - val)))) - -(define (write-hash h) - (write (hash-fold acons '() h))) - -;; fixme: doesn't share structure with posts index -(define (read-hash) - (let ((h (make-hash-table))) - (for-each (lambda (pair) - (hash-set! h (car pair) (cdr pair))) - (read)) - h)) - -(define indices - `((posts ,reindex-posts ,write ,read) - (categories ,reindex-categories ,write-hash ,read-hash))) - -(use-modules (statprof)) -(define (reindex oldindex master) - (with-backtrace - (lambda () - (with-time-debugging - (lambda () - (with-statprof #:hz 100 - (fold (lambda (pair index) - (acons (car pair) - ((cadr pair) oldindex index) - index)) - (acons 'master master '()) - indices))))))) - -(define (maybe-reindex old-index) - (let ((master (git-rev-parse "master"))) - (if (and old-index (equal? (assq-ref (cdr old-index) 'master) master)) - old-index - (catch #t - (lambda () - (let ((new-index (reindex (and=> old-index cdr) master))) - (cons (write-indices new-index (and=> old-index car) indices) - new-index))) - (lambda (key . args) - (warn "error while reindexing:" key args) - old-index))))) - (define (inner-loop socket index) (let* ((pair (accept socket)) (fd (car pair)) @@ -185,5 +117,5 @@ (with-socket (lambda (socket) (format #t "entering inner loop\n") - (inner-loop socket (read-indices indices))))) + (inner-loop socket (read-index))))) diff --git a/tekuti/page.scm b/tekuti/page.scm index f0f0ceb..a6c4758 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -170,7 +170,7 @@ (div (@ (class "post")) (h3 (@ (class "meta")) ,(post-readable-date post) - " (" ,@(list-intersperse (post-category-links post) + " (" ,@(list-intersperse (post-tag-links post) " | ") ")") (div (@ (class "storycontent")) @@ -191,14 +191,18 @@ (define page-delete-comment not-implemented) (define page-delete-post not-implemented) +;; 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* ((cats (hash-fold (lambda (k v seed) (acons k (length v) seed)) - '() (assq-ref index 'categories))) + (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>")) @@ -372,6 +377,10 @@ (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) "~Y-~m-~dT~H:~M:~SZ")) +(define (timestamp->rfc822-date timestamp) + (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) + "~a, ~d ~b ~Y ~H:~M:~S GMT")) + (define (request-relurl request) (let ((headers (rref request 'headers))) (let ((server (or (assoc-ref headers "Host") @@ -392,7 +401,10 @@ 'status 304 'doctype #f)) (else - (rcons* request + (rcons* (rpush 'output-headers (cons "Last-Modified" + (timestamp->rfc822-date + last-modified)) + request) 'doctype "" 'content-type "application/atom+xml" 'sxml `(feed diff --git a/tekuti/post.scm b/tekuti/post.scm index 6138c11..f8e0970 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -35,10 +35,10 @@ #: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 + #:export (reindex-posts post-from-tree post-from-key post-tags + post-timestamp post-key post-sxml-content post-raw-content all-published-posts - post-readable-date post-category-links post-sxml-n-comments + post-readable-date post-tag-links post-sxml-n-comments post-sxml-comments)) @@ -49,14 +49,17 @@ (equal? (assq-ref post-alist 'status) "publish")) (define (post-timestamp post-alist) - (or (assq-ref post-alist 'timestamp) #f)) + (assq-ref post-alist 'timestamp)) -(define (post-categories post-alist) - (or (assq-ref post-alist 'categories) '())) +(define (post-tags post-alist) + (or (assq-ref post-alist 'tags) '())) + +(define (post-key post) + (assq-ref post 'key)) (define *post-spec* `((timestamp . ,string->number) - (categories . ,(lambda (v) (map string-trim-both (string-split v #\,)))) + (tags . ,(lambda (v) (map string-trim-both (string-split v #\,)))) (title . ,identity))) (define (post-from-tree encoded-name sha1) @@ -80,12 +83,14 @@ (make-time time-utc 0 (assq-ref post 'timestamp))))) (date->string date "~e ~B ~Y ~l:~M ~p"))) -(define (post-category-links post) - (map (lambda (cat) - `(a (@ (href ,(string-append *public-url-base* "tags/" - (url:encode cat)))) - ,cat)) - (post-categories post))) +;; hack :-/ +(define (tag-link tagname) + `(a (@ (href ,(string-append *public-url-base* "tags/" + (url:encode tagname)))) + ,tagname)) + +(define (post-tag-links post) + (map tag-link (post-tags post))) (define (post-from-key master key) (let ((pairs (git-ls-subdirs master key))) diff --git a/tekuti/tags.scm b/tekuti/tags.scm new file mode 100644 index 0000000..6df1a0b --- /dev/null +++ b/tekuti/tags.scm @@ -0,0 +1,52 @@ +;; 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: +;; +;; Tags, tags, tags +;; +;;; Code: + +(define-module (tekuti tags) + #:use-module (tekuti util) + #:use-module (tekuti url) + #:use-module (tekuti config) + #:use-module (tekuti post) + #:use-module (tekuti git) + #:export (tag-link reindex-tags)) + +(define (tag-link tagname) + `(a (@ (href ,(string-append *public-url-base* "tags/" + (url:encode tagname)))) + ,tagname)) + +(define (compute-tags posts) + (let ((hash (make-hash-table))) + (for-each + (lambda (post) + (for-each + (lambda (cat) + (hash-push! hash cat (assq-ref post 'key))) + (post-tags post))) + posts) + hash)) + +(define (reindex-tags old-index index) + (compute-tags (assq-ref index 'posts))) diff --git a/tekuti/util.scm b/tekuti/util.scm index 6017055..35c0c78 100644 --- a/tekuti/util.scm +++ b/tekuti/util.scm @@ -29,8 +29,8 @@ #:use-module (srfi srfi-1) #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort hash-push! list-has-length? list-head-match mapn - take-max - list-intersperse with-backtrace define-memoized)) + take-max read-hash write-hash + list-intersperse with-backtrace with-time-debugging define-memoized)) (define (expanduser path) (let ((parts (string-split path #\/))) @@ -115,7 +115,7 @@ (force-output cep) (apply throw key args))) -(define (with-backtrace proc) +(define (with-backtrace* proc) (debug-enable 'backtrace) (start-stack 'with-backtrace (catch #t @@ -125,6 +125,24 @@ (fluid-set! the-last-stack (make-stack #t 2 0)) (apply throw args))))) +(define-macro (with-backtrace . forms) + `(,with-backtrace* (lambda () ,@forms))) + +(define (gettimeofday-diff prev) + (let ((now (gettimeofday))) + (+ (- (car now) (car prev)) + (* 1e-6 (- (cdr now) (cdr prev)))))) + +(define (with-time-debugging* proc) + (pk 'start-clock) + (let ((start (gettimeofday))) + (unwind-protect + (proc) + (pk 'stop-clock (gettimeofday-diff start))))) + +(define-macro (with-time-debugging . forms) + `(,with-time-debugging* (lambda () ,@forms))) + (define (memoize1 proc) (let ((old-args #f) (cache #f) (proc proc)) (lambda args @@ -139,3 +157,14 @@ `(begin (define ,form ,@body) (set! ,(car form) (,memoize1 ,(car form))))) + +(define (write-hash h) + (write (hash-fold acons '() h))) + +(define (read-hash) + (let ((h (make-hash-table))) + (for-each (lambda (pair) + (hash-set! h (car pair) (cdr pair))) + (read)) + h)) + diff --git a/tekuti/web.scm b/tekuti/web.scm index 9f782a7..eebb212 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -63,13 +63,19 @@ bindings)) ,@body)))) +(define (make-output request) + (lambda (port) + (let ((sxml (or (rref request 'sxml #f) + (templatize request)))) + (if sxml + (begin (display (rref request 'doctype "") port) + (sxml->xml sxml port)) + (display "" port))))) + (define (finalize request) ;; update output headers ;; templatize body - (rpush* (if (assq 'sxml request) - request - (rcons 'sxml (templatize request) - request)) + (rpush* (rcons 'output (make-output request) request) 'output-headers (cons "Status" (status->string (rref request 'status 200))) 'output-headers -- cgit v1.2.3-54-g00ecf