aliens/tekuti
1
0
Fork 0
Code Activity

incremental reindexing, import charset fixes, other thingies

Browse source
This commit is contained in:
Andy Wingo 2008-02-27 21:42:10 +01:00
parent bc57e2a655
commit 227bc9cea1
9 changed files with 93 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
tekuti/categories.scm
View file

@ -41,5 +41,5 @@
posts)
hash))
(define (reindex-categories index)
(define (reindex-categories old-index index)
(compute-categories (assq-ref index 'posts)))

79
tekuti/comment.scm
View file

@ -220,37 +220,36 @@
(assert-added-files-not-present (map cadr ladd) dents)
(assert-referenced-files-present
(append (map cdr lremove) (map caar lchange)) dents)
(pk 'make-tree-deep treeish add remove change)
; (trc 'make-tree-deep treeish add remove change)
(make-tree-full
(pk 'making (append
(map cdr ladd)
(filter-map
(lambda (dent)
(cond
((member (car dent) (map cdr lremove))
#f)
((member (car dent) (map cadr lchange))
(cdr lchange))
((and (equal? (caddr dent) "tree")
(member (car dent)
(map caar (append dadd dremove dchange))))
(pk 'hi! dent (map caar (append dadd dremove dchange)))
(let ((level-down (lambda (x)
(if (equal? (caar x) (car dent))
(cons (cdar x) (cdr x))
#f))))
(list (car dent)
(make-tree-deep (cadr dent)
(filter-map level-down dadd)
(filter-map level-down dremove)
(filter-map level-down dchange))
"tree" "040000")))
(else dent)))
(append (filter-map (lambda (x)
(and (not (assoc (caar x) dents))
(list x "tree" #f #f))
dadd))
dents)))))))
(append
(map cdr ladd)
(filter-map
(lambda (dent)
(cond
((member (car dent) (map cdr lremove))
#f)
((member (car dent) (map cadr lchange))
(cdr lchange))
((and (equal? (caddr dent) "tree")
(member (car dent)
(map caar (append dadd dremove dchange))))
(let ((level-down (lambda (x)
(if (equal? (caar x) (car dent))
(cons (cdar x) (cdr x))
#f))))
(list (car dent)
(make-tree-deep (cadr dent)
(filter-map level-down dadd)
(filter-map level-down dremove)
(filter-map level-down dchange))
"tree" "040000")))
(else dent)))
(append (filter-map (lambda (x)
(and (not (assoc (caar x) dents))
(list (caar x) #f "tree" #f)))
dadd)
dents))))))
(define (mutate-tree master add remove change message)
(let ((tree (make-tree-deep master add remove change)))
@ -258,19 +257,6 @@
(git* `("commit-tree" ,tree "-p" ,master) #:input message
#:env '("GIT_COMMMITTER=tekuti")))))
(define (update-master proc)
(let lp ((master (git-rev-parse "master")) (count 5))
(let ((commit (proc master)))
(cond
((zero? count)
(error "my god, we looped 5 times" commit))
((false-if-git-error
(git "update-ref" "refs/heads/master" commit master))
commit)
(else
(pk "failed to update the master ref, trying again...")
(lp (git-rev-parse "master") (1- count)))))))
(define (make-new-comment post post-data)
(let ((content (assoc-ref post-data "comment"))
(author (assoc-ref post-data "author"))
@ -291,11 +277,14 @@
(author_url . ,url)))
(display "\n")
(display content))))))
(update-master
(git-update-ref
"refs/heads/master"
(lambda (master)
(mutate-tree master
`(((,(assq-ref post 'key) "comments") . (,sha1 ,sha1 "blob" "100644")))
'()
'()
"new comment"))))))
"new comment"))
5))))

15
tekuti/filters.scm
View file

@ -68,7 +68,7 @@
(scons tail (cdr in)) out)
(lp #f (scons tail (cdr in))
(pclose (scons head p) out)))
(lp (cons (car in) (or p '()))
(lp (scons (car in) p)
(cdr in) out)))
((inline? (caar in))
(lp (scons (car in) p) (cdr in) out))
@ -76,21 +76,18 @@
(lp #f (cdr in)
(cons (car in) (pclose p out))))))))
(wpautop 'div
`((b "foo") "\n\n" (b "bar")))
(define (wordpress->sxml text)
(catch 'parser-error
(lambda ()
(let ((sxml (cadr (with-input-from-string (string-append "<div>" text "</div>")
xml->sxml))))
(pre-post-order
sxml
(pk sxml)
`((*default* . ,(lambda (tag . body)
(if (can-contain-p? tag)
(wpautop tag body)
(cons tag body))))
(*text* . ,(lambda (tag text)
text))))))
(lambda (key . args)
`(pre "parse error: "
,(with-output-to-string (lambda () (write args)))
"\n"
,text))))

20
tekuti/git.scm
View file

@ -39,7 +39,7 @@
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
create-blob
create-blob git-update-ref
write-indices read-indices))
@ -63,7 +63,7 @@
(string->list str))
(display #\'))))
(define *debug* #t)
(define *debug* #f)
(define (trc . args)
(if *debug*
(apply pk args)
@ -88,7 +88,8 @@
(ret (close-pipe pipe)))
(case (status:exit-val ret)
((0) (if (eof-object? output) "" output))
(else (raise (condition (&git-condition
(else (trc 'git-error output ret real-args)
(raise (condition (&git-condition
(argv real-args)
(output output)
(status ret))))))))
@ -211,6 +212,19 @@
alist)
"\n" 'suffix))))
(define (git-update-ref refname proc count)
(let* ((ref (git-rev-parse refname))
(commit (proc ref)))
(cond
((zero? count)
(error "my god, we looped 5 times" commit))
((false-if-git-error
(git "update-ref" refname commit ref))
commit)
(else
(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)

16
tekuti/mod-lisp.scm
View file

@ -147,14 +147,15 @@
(categories ,reindex-categories ,write-hash ,read-hash)))
(use-modules (statprof))
(define (reindex master)
(define (reindex oldindex master)
(with-backtrace
(lambda ()
(with-time-debugging
(lambda ()
(with-statprof #:hz 100
(fold (lambda (pair index)
(acons (car pair) ((cadr pair) index)
(acons (car pair)
((cadr pair) oldindex index)
index))
(acons 'master master '())
indices)))))))
@ -163,9 +164,14 @@
(let ((master (git-rev-parse "master")))
(if (and old-index (equal? (assq-ref (cdr old-index) 'master) master))
old-index
(let ((new-index (reindex master)))
(cons (write-indices new-index (and=> old-index car) indices)
new-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))

2
tekuti/page.scm
View file

@ -390,7 +390,7 @@
(else
(rcons* request
'doctype ""
'output-type "application/atom+xml"
'content-type "application/atom+xml"
'sxml `(feed
(@ (xmlns "http://www.w3.org/2005/Atom")
(xml:base ,(relurl "feed/atom")))

22
tekuti/post.scm
View file

@ -166,7 +166,7 @@
,(comment-form post "" "" "" ""))))))
(define (post-n-comments post)
(length (git-ls-subdirs (string-append (assq-ref post 'sha1) ":comments") #f)))
(length (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f)))
(define (post-sxml-n-comments post)
`(div (@ (class "feedback"))
@ -175,5 +175,21 @@
"#comments")))
"(" ,(post-n-comments post) ")")))
(define (reindex-posts index)
(all-published-posts (assq-ref index 'master)))
(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
>)))

13
tekuti/web.scm
View file

@ -52,15 +52,6 @@
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
;; what the hell is this
(define (request-output-headers request)
(let-request request ((output-headers '())
(status 200)
(content-type "text/html"))
(acons "Status" (status->string status)
(acons "Content-Type" content-type
output-headers))))
;;; useless macro
(define-macro (let-headers headers bindings . body)
(let ((headers-var (gensym)))
@ -82,7 +73,9 @@
'output-headers
(cons "Status" (status->string (rref request 'status 200)))
'output-headers
(cons "Content-Type" (rref request 'content-type "text/html"))))
(cons "Content-Type"
(string-append (rref request 'content-type "text/html")
"; charset=utf-8"))))
(define (choose-handler request)
(request-path-case

1
wordpress-to-dir.py
View file

@ -98,6 +98,7 @@ def main(args):
os.chdir(d)
_, host, user, passwd, database = args
cxn = db.connect(host=host, user=user, passwd=passwd, db=database)
cxn.cursor().execute("set names 'utf8'")
for post in all_posts():
write_post (post, post_categories (post), post_comments (post))