Merge remote-tracking branch 'origin/master' into customizations

When starting a new blog, or trying to run on some very old data, there is no
data available on any bogus or legitimate comments. When this happens Tekuti
will try to divide by 0 and divide 0 by other things in a few places, assuming
that there is at least _some_ data about bogus and legitimate comments.

I’m not 100% sure what the expectation is of these calculations, so I might have
chosen the wrong solution, but it seems to me that if there is no data
available, all we know is that there is nothing (0).

This fixes an issue with both trying to comment on a fresh new data set, or a
dataset that hasn’t been touched since 2014.

tekuti/classifier.scm

@@ -114,16 +114,22 @@
      (lambda (feature bogus-count)
        (let ((legit-count (hash-ref legit-features feature 0)))
          (hash-set! log-bogosities feature
-                    (log (/ (/ (+ bogus-count 0.001) total-bogus-features)
-                            (/ (+ legit-count 0.001) total-legit-features))))))
+                    (if (and (> total-bogus-features 0)
+                             (> total-legit-features 0))
+                        (log (/ (/ (+ bogus-count 0.001) total-bogus-features)
+                                (/ (+ legit-count 0.001) total-legit-features)))
+                        0))))
      bogus-features)
     (hash-for-each
      (lambda (feature legit-count)
        (let ((bogus-count (hash-ref bogus-features feature)))
          (unless bogus-count
            (hash-set! log-bogosities feature
-                      (log (/ (/ 0.01 total-bogus-features)
-                              (/ (+ legit-count 0.01) total-legit-features)))))))
+                      (if (and (> total-bogus-features 0)
+                               (> total-legit-features 0))
+                          (log (/ (/ 0.01 total-bogus-features)
+                                  (/ (+ legit-count 0.01) total-legit-features)))
+                          0)))))
      legit-features)
     log-bogosities))
 
@@ -256,7 +262,9 @@
   (with-time-debugging
    (let* ((legit-count (hash-count (const #t) legit-comments))
           (bogus-count (hash-count (const #t) bogus-comments))
-          (legit-prior (/ legit-count (+ legit-count bogus-count 0.0)))
+          (legit-prior (if (> legit-count 0)
+                           (/ legit-count (+ legit-count bogus-count 0.0))
+                           0))
           (legit-features (count-features legit-comments))
           (bogus-features (count-features bogus-comments))
           (bogosities (compute-log-bogosities legit-features bogus-features)))
@@ -283,13 +291,19 @@
                                                (assq-ref index 'master))))
        (let ((removed-features (count-features removed))
              (added-features (count-features added)))
+         ;; If a comment passes the spam filter, it gets added, and is
+         ;; presumed legitimate.  It could then be reverted, in which
+         ;; case we should remove its features from the legitimate count
+         ;; and add them to the bogus count.
          (hash-for-each (lambda (k v)
                           (remove-feature! legit-features k v)
                           (add-feature! bogus-features k v))
                         removed-features)
          (hash-for-each (lambda (k v)
-                          (add-feature! legit-features k v)
-                          (remove-feature! bogus-features k v))
+                          ;; Asymmetry with removed-features; the
+                          ;; comment wasn't previously marked bogus, so
+                          ;; we just add its features to the legit set.
+                          (add-feature! legit-features k v))
                         added-features)
          (update-bogosities! bogosities removed-features
                              legit-features bogus-features)

tekuti/filters.scm

@@ -94,6 +94,9 @@
 (define (marxdown->sxml text)
   (smarxdown->shtml (call-with-input-string text marxdown->smarxdown)))
 
+(define (pre-class? class)
+  (string-prefix? "pre-" class))
+
 (define *allowed-tags*
   `((a (href . ,urlish?) title)
     (abbr title)
@@ -105,9 +108,10 @@
     (em)
     (i)
     (p)
-    (pre)
+    (pre (class . ,pre-class?))
     (strike)
-    (strong)))
+    (strong)
+    (tt)))
 
 (define (compile-sxslt-rules tags)
   (define (ok . body)

tekuti/git.scm

@@ -334,7 +334,7 @@
                    (cons (string->symbol k) v))))))
 
 (define (fold-commits f rev seed)
-  (let lp ((rev (git-rev-parse rev)) (seed seed))
+  (let lp ((rev (and rev (git-rev-parse rev))) (seed seed))
     (if rev
         (let ((commit (parse-commit rev)))
           (lp (assq-ref commit 'parent)

tekuti/marxdown.scm

@@ -132,13 +132,28 @@
        (unget chars))))
 
   (define (next) (get-char port))
+  (define (peek) (peek-char port))
+
   (define (next-not-eof ctx)
     (let ((ch (next)))
       (if (eof-object? ch)
           (error "EOF while reading" ctx)
           ch)))
-  (define (next-line-and-delim) (read-line port 'split))
-  (define (peek) (peek-char port))
+  (define (next-line-and-delim)
+    (let lp ((chars '()))
+      (define (finish delim)
+        (cons (reverse-list->string chars) delim))
+      (let ((ch (next)))
+        (cond
+         ((eof-object? ch) (finish ch))
+         ((eqv? ch #\return)
+          (if (eqv? (peek) #\newline)
+              (finish (next))
+              (lp (cons ch chars))))
+         ((eqv? ch #\newline)
+          (finish ch))
+         (else
+          (lp (cons ch chars)))))))
 
   (define (skip-whitespace k)
     (let lp ((indent 0))
@@ -212,7 +227,10 @@
               (else (kt)))))
           (#\newline
            ;; Sure.  Trailing whitespace can be any indent.
+           (unget1 #\newline)
            (kt))
+          (#\return
+           (lp n))
           (ch
            (unless (eof-object? ch) (unget1 ch))
            (kf)))))))
@@ -347,12 +365,14 @@
     (let lp ((chars '()))
       (match (next-not-eof "backticks")
         (#\` (continue `(code ,(reverse-list->string chars))))
+        (#\return (lp chars))
         (#\newline
          (consume-indent
           indent
           (lambda ()
             (match (next-not-eof "code")
-              (#\newline (error "end of block while reading code"))
+              ((or #\return #\newline)
+               (error "end of block while reading code"))
               (ch (unget1 ch) (lp (cons #\space chars)))))
           (lambda () (error "end of block while reading code"))))
         (ch (lp (cons ch chars))))))
@@ -373,14 +393,25 @@
                   (lp elts (cons (list->string chars) out))))))
             ((elt . elts)
              (lp elts (cons elt out))))))
+      (define (consume-blank-lines-then-finish kdone)
+        (let lp ()
+          (match (next)
+            ((? eof-object?) (finish kdone))
+            (#\return (lp))
+            (#\newline
+             (consume-indent indent lp (lambda () (finish kdone))))
+            (ch
+             (unget1 ch)
+             (finish kdone)))))
       (match (next)
         ((? eof-object?) (finish on-block-end))
+        (#\return (lp elts))
         (#\newline
          (consume-indent
           indent
           (lambda ()
             (cond
-             ((done? #\newline) => finish)
+             ((done? #\newline) => consume-blank-lines-then-finish)
              (else (lp (cons #\newline elts)))))
           (lambda ()
             (finish on-block-end))))
@@ -403,7 +434,9 @@
                              (match link
                                (('link dest . alt)
                                 (continue `(image ,dest . ,alt)))))))
-               (ch (lp (cons* ch #\! elts)))))
+               (ch
+                (unget1 ch)
+                (lp (cons #\! elts)))))
         (ch (lp (cons ch elts))))))
 
   (define (read-para indent kup knext)
@@ -414,7 +447,7 @@
     (define (done? ch)
       (match ch
         (#\newline
-         (let ((ch (next)))
+         (let lp ((ch (next)))
            (match ch
              ((? eof-object?)
               (lambda (para)
@@ -422,9 +455,13 @@
              (ch
               (read-block-type ch #t
                                make-continuation
-                               (lambda (chars)
-                                 (unget chars)
-                                 #f))))))
+                               (if (eqv? ch #\newline)
+                                   (lambda (chars)
+                                     (unget chars)
+                                     (make-continuation read-para))
+                                   (lambda (chars)
+                                     (unget chars)
+                                     #f)))))))
         (_ #f)))
     (read-text 'para indent done? (make-continuation read-block-list)))
 
@@ -432,10 +469,21 @@
     (unget chars)
     (read-para indent kup knext))
 
-  (define (read-heading level knext)
-    (error "unimplemented"))
+  (define (read-heading level indent continue)
+    (let ((continue (lambda (heading)
+                      (match heading
+                        (('heading . body)
+                         (continue `(heading ,level . ,body)))))))
+      (read-text 'heading indent (lambda (ch)
+                                   (and (eqv? ch #\newline) continue))
+                 continue)))
 
   (define (read-li marker marker-indent marker-size kup knext)
+    (define list-tag
+      (match marker
+        ((? number?) 'enumerate)
+        ((? char?) 'itemize)))
+    (define (list-tag? tag) (eq? tag list-tag))
     (read-indent
      (lambda (ch indent)
        (match indent
@@ -446,23 +494,19 @@
                     (append marker-outer
                             (list (+ marker-inner marker-size outer))
                             inner)))
-               (pk 'hey marker marker-indent marker-size indent body-indent ch)
-               (read-indented-block
-                ch marker-indent body-indent
-                (lambda (elt ch indent)
-                  (pk ch marker-indent indent elt)
-                  (read-indented-block ch marker-indent indent kup
-                                       (lambda (nodelist)
-                                         (knext (cons elt nodelist)))))
-                (lambda (nodelist)
-                  (cons* 'li marker nodelist)))))))))))
-
-  (define (read-block ch indent kup knext)
-    (define (have-block read-block)
-      (read-block indent kup knext))
-    (define (have-text chars)
-      (read-para* chars indent kup knext))
-    (read-block-type ch #f have-block have-text))
+               (read-block
+                ch body-indent
+                (lambda (blocks ch next-indent)
+                  (read-indented-block
+                   ch marker-indent next-indent kup
+                   (lambda (nodelist)
+                     (knext
+                      (match nodelist
+                        ((((? list-tag?) . items) . nodelist)
+                         `((,list-tag (item . ,blocks) . ,items) . ,nodelist))
+                        (_
+                         `((,list-tag (item . ,blocks)) . ,nodelist)))))))
+                identity)))))))))
 
   (define (read-block-type ch in-text? kblock ktext)
     (define (make-continue indent kup knext)
@@ -479,7 +523,8 @@
            (#\space
             (kblock
              (lambda (indent kup knext)
-               (read-heading level (make-continue indent kup knext)))))
+               (read-heading level indent (make-continue indent kup knext)))))
+           (#\return (lp level))
            (#\newline
             (kblock
              (lambda (indent kup knext)
@@ -552,6 +597,8 @@
               (match (parse-one-xml-element port)
                 (#f (read-block-list indent kup knext))
                 (elt ((make-continue indent kup knext) `(block-xml ,elt))))))))
+      (#\return
+       (read-block-type (next-not-eof "newline") in-text? kblock ktext))
       (#\newline
        ;; fixme: record loose li
        (kblock read-block-list))
@@ -562,16 +609,31 @@
       (_
        (ktext (list ch)))))
 
+  (define (read-block ch indent kup knext)
+    (define (have-block read-block)
+      (read-block indent kup knext))
+    (define (have-text chars)
+      (read-para* chars indent kup knext))
+    (read-block-type ch #f have-block have-text))
+
+  (define (finish-block-list blocks)
+    (match blocks
+      ((block) block)
+      (_ `(begin . ,blocks))))
+  (define (finish-block-quote blocks)
+    (match blocks
+      ((block) block)
+      (_ `(blockquote . ,blocks))))
+
   (define (read-indented-block ch outer-indent indent kup knext)
-    (define (recurse kind recurse-indent)
+    (define (recurse finish recurse-indent)
       (read-indented-block ch recurse-indent indent
                            (lambda (nested ch indent)
                              (read-indented-block ch outer-indent indent
                                                   kup
                                                   (lambda (nodelist)
                                                     (knext (cons nested nodelist)))))
-                           (lambda (nodelist)
-                             (cons kind nodelist))))
+                           finish))
     (match (compare-indents outer-indent indent)
       ('same
        (read-block ch indent kup knext))
@@ -580,9 +642,10 @@
            'different-blockquote)
        (kup (knext '()) ch indent))
       ('inner
-       (recurse 'begin indent))
+       (recurse finish-block-list indent))
       ('inner-blockquote
-       (recurse 'blockquote (list-head indent (1+ (length outer-indent)))))))
+       (recurse finish-block-quote
+                (list-head indent (1+ (length outer-indent)))))))
 
   (define (parse-error reason)
     (error reason))
@@ -594,7 +657,7 @@
 
   (read-block-list empty-indent
                    (lambda (nodelist ch indent) nodelist)
-                   (lambda (nodelist) (cons 'top nodelist))))
+                   finish-block-list))
 
 (define* (smarxdown->shtml exp #:key
                            (heading-offset 0)
@@ -603,9 +666,9 @@
   (define (transform-inline exp)
     (match exp
       (('inline-xml xml) (handle-inline-xml xml))
-      (('code . body) exp)
-      (('emph . body) `(emph . ,(map transform-inline body)))
-      (('strong . body) `(strong . ,(map transform-inline body)))
+      (('code . body) `(tt . ,body))
+      (('emph . body) `(i . ,(map transform-inline body)))
+      (('strong . body) `(b . ,(map transform-inline body)))
       (('link dest . body) `(a (@ (href ,dest)) . ,(map transform-inline body)))
       ((? string? str) str)))
   (define (transform-block exp)
@@ -613,7 +676,14 @@
       (('block-xml xml) (handle-block-xml xml))
       (('para . body) `(p . ,(map transform-inline body)))
       (('blockquote . body) `(blockquote . ,(map transform-block body)))
-      (('list-item . body) (error "fixme"))
+      (('itemize ('item . item) ...)
+       `(ul . ,(map (lambda (blocks)
+                      `(li . ,(map transform-block blocks)))
+                    item)))
+      (('enumerate ('item . item) ...)
+       `(ol . ,(map (lambda (blocks)
+                      `(li . ,(map transform-block blocks)))
+                    item)))
       (('pre #f . body) `(pre . ,body))
       (('pre info . body) `(pre (@ (class ,(string-append "pre-" info)))
                                 . ,body))
@@ -627,5 +697,5 @@
                          (else 'h6))))
          `(,tag . ,(map transform-inline body))))))
   (match exp
-    (('top exp ...)
+    (('begin exp ...)
      `(div . ,(map transform-block exp)))))

tekuti/page-helpers.scm

@@ -45,7 +45,7 @@
             post-url
             post-editing-form
             sidebar-ul top-tags tag-cloud
-            main-sidebar post-sidebar related-tag-cloud
+            main-sidebar post-sidebar tag-sidebar related-tag-cloud
             post-link admin-post-url admin-post-link
             show-post with-authentication
             find-posts-matching
@@ -540,6 +540,17 @@ present."
                            ,(post-link (car post-and-tags))))
                     (take-max (compute-related-posts post index) 10)))))))
 
+(define (tag-sidebar tag index)
+  (sidebar-ul
+   `((li (h2 (a (@ (href ,(relurl '("feed" "atom")
+                                  #:query `(("with" . ,tag)))))
+                "subscribe "
+                (img (@ (src ,(relurl '("wp-content" "feed-icon-14x14.png")))
+                        (alt "[feed]"))))))
+     (li (h2 "related tags " ,(rellink '("tags") ">>"))
+         (ul (li (@ (style "line-height: 150%"))
+                 ,@(tag-cloud (compute-related-tags tag index))))))))
+
 (define (related-tag-cloud tag index)
   `(div (@ (id "tag-cloud"))
         (h2 "related tags")

tekuti/page.scm

@@ -301,13 +301,10 @@
                        (post-from-key index key))
                      (hash-ref tags tag '()))))
     (if (pair? posts)
-        (respond `((h2 "posts tagged \"" ,tag "\" ("
-                       ,(rellink '("feed" "atom") "feed"
-                                 #:query `(("with" . ,tag)))
-                       ")")
-                   ,@(map (lambda (post) `(p ,(post-link post)))
-                          posts)
-                   ,(related-tag-cloud tag index))
+        (respond `(,(tag-sidebar tag index)
+                   (h2 "posts tagged \"" ,tag "\"")
+                   ,@(map (lambda (post) (show-post post #f))
+                          (take-max (reverse posts) 10)))
                  #:etag (assq-ref index 'master)
                  #:title (string-append "posts tagged \"" tag "\""))
         (respond `((h2 "Unknown tag " ,tag)