aliens/tekuti
1
0
Fork 0
Code Activity

continuing simplification work

Browse source
This commit is contained in:
Andy Wingo 2008-02-28 14:28:38 +01:00
parent eae227142c
commit 436ef22134
9 changed files with 129 additions and 179 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
tekuti/boot.scm
View file

@ -1,7 +1,3 @@
#! /bin/bash
# -*- scheme -*-
exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
!#
;; Tekuti
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
@ -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)

8
tekuti/comment.scm
View file

@ -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))))))

79
tekuti/git.scm
View file

@ -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))))))
(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))))))
;; 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 (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))))))

88
tekuti/mod-lisp.scm
View file

@ -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)))))

24
tekuti/page.scm
View file

@ -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<?)))
`(ul (li (@ (style "line-height: 150%"))
@ -218,9 +222,10 @@
(define (main-sidebar request index)
(sidebar-ul
`((li (h2 (a (@ (href ,(relurl "feed/atom")))
(img (@ (href ,(relurl "wp-content/feed-icon-14x14.png"))
"subscribe "
(img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
(alt "subscribe to this feed")))
" subscribe")))
)))
(li (h2 "tags "
(a (@ (href ,(string-append *public-url-base* "tags/")))
">>"))
@ -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

29
tekuti/post.scm
View file

@ -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)
;; hack :-/
(define (tag-link tagname)
`(a (@ (href ,(string-append *public-url-base* "tags/"
(url:encode cat))))
,cat))
(post-categories post)))
(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)))

21
tekuti/categories.scm → tekuti/tags.scm
View file

@ -20,26 +20,33 @@
;;; Commentary:
;;
;; This is the main script that will launch tekuti.
;; Tags, tags, tags
;;
;;; Code:
(define-module (tekuti categories)
(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 (reindex-categories))
#:export (tag-link reindex-tags))
(define (compute-categories posts)
(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-categories post)))
(post-tags post)))
posts)
hash))
(define (reindex-categories old-index index)
(compute-categories (assq-ref index 'posts)))
(define (reindex-tags old-index index)
(compute-tags (assq-ref index 'posts)))

35
tekuti/util.scm
View file

@ -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))

14
tekuti/web.scm
View file

@ -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