diff --git a/tekuti/categories.scm b/tekuti/categories.scm index 332d64a..daee4be 100644 --- a/tekuti/categories.scm +++ b/tekuti/categories.scm @@ -41,5 +41,5 @@ posts) hash)) -(define (reindex-categories index) +(define (reindex-categories old-index index) (compute-categories (assq-ref index 'posts))) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index 2454516..0998284 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -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)))) + diff --git a/tekuti/filters.scm b/tekuti/filters.scm index 7fb7369..5056883 100644 --- a/tekuti/filters.scm +++ b/tekuti/filters.scm @@ -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 "
" text "
") 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)))) diff --git a/tekuti/git.scm b/tekuti/git.scm index aede954..355d3b1 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -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) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index c17a3ac..eb23689 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -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)) diff --git a/tekuti/page.scm b/tekuti/page.scm index bf8d7c0..ee780ec 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -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"))) diff --git a/tekuti/post.scm b/tekuti/post.scm index cafd4e0..1bc1cc4 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -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 + >))) + diff --git a/tekuti/web.scm b/tekuti/web.scm index 6028ea3..a9b0e48 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -52,15 +52,6 @@ "\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 diff --git a/wordpress-to-dir.py b/wordpress-to-dir.py index 2c9f17a..239c80a 100644 --- a/wordpress-to-dir.py +++ b/wordpress-to-dir.py @@ -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))