incremental reindexing, import charset fixes, other thingies

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

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
+     (append
-       (map cdr ladd)
+      (map cdr ladd)
-       (filter-map
+      (filter-map
-        (lambda (dent)
+       (lambda (dent)
-          (cond
+         (cond
-           ((member (car dent) (map cdr lremove))
+          ((member (car dent) (map cdr lremove))
-            #f)
+           #f)
-           ((member (car dent) (map cadr lchange))
+          ((member (car dent) (map cadr lchange))
-            (cdr lchange))
+           (cdr lchange))
-           ((and (equal? (caddr dent) "tree")
+          ((and (equal? (caddr dent) "tree")
-                 (member (car dent)
+                (member (car dent)
-                         (map caar (append dadd dremove dchange))))
+                        (map caar (append dadd dremove dchange))))
-            (pk 'hi! dent (map caar (append dadd dremove dchange)))
+           (let ((level-down (lambda (x)
-            (let ((level-down (lambda (x)
+                               (if (equal? (caar x) (car dent))
-                                (if (equal? (caar x) (car dent))
+                                   (cons (cdar x) (cdr x))
-                                    (cons (cdar x) (cdr x))
+                                   #f))))
-                                    #f))))
+             (list (car dent)
-              (list (car dent)
+                   (make-tree-deep (cadr dent)
-                    (make-tree-deep (cadr dent)
+                                   (filter-map level-down dadd)
-                                    (filter-map level-down dadd)
+                                   (filter-map level-down dremove)
-                                    (filter-map level-down dremove)
+                                   (filter-map level-down dchange))
-                                    (filter-map level-down dchange))
+                   "tree" "040000")))
-                    "tree" "040000")))
+          (else dent)))
-           (else dent)))
+       (append (filter-map (lambda (x)
-        (append (filter-map (lambda (x)
+                             (and (not (assoc (caar x) dents))
-                              (and (not (assoc (caar x) dents))
+                                  (list (caar x) #f "tree" #f)))
-                                   (list x "tree" #f #f))
+                           dadd)
-                              dadd))
+               dents))))))
-                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))))
+
 

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

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)

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)))
+        (catch #t
-          (cons (write-indices new-index (and=> old-index car) indices)
+               (lambda ()
-                new-index)))))
+                 (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))

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

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)
+(define (hash-fill proc list)
-  (all-published-posts (assq-ref index 'master)))
+  (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
+              >)))
+

tekuti/web.scm

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

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