aliens/tekuti
1
0
Fork 0
Code Activity

Merge branch 'initial-startup-fix' into customizations

Browse source
This commit is contained in:
Tom Willemse 2021-05-30 19:27:03 -07:00
commit d34a14b3d6
14 changed files with 848 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -4,6 +4,7 @@ SOURCES = \
tekuti/base64.scm \
tekuti/boot.scm \
tekuti/cache.scm \
tekuti/classifier.scm \
tekuti/comment.scm \
tekuti/config.scm \
tekuti/filters.scm \

17
example-config Normal file
View file

@ -0,0 +1,17 @@
;; -*- scheme -*-
(set! *navbar-links*
'(("about" . "/about/")
("cat pictures" . "/cat-pictures/")))
(set! *navbar-infix* " | ")
(set! *public-host* "example.com")
(set! *public-port* 80)
(set! *public-path-base* '())
(set! *private-host* "127.0.0.1")
(set! *private-port* 8080)
(set! *private-path-base* '())
(define *admin-pass* "password")
(define *title* "kittens")
(define *subtitle* "all about kittens")
(define *name* "Jane Doe")

24
nginx-config Normal file
View file

@ -0,0 +1,24 @@
server {
listen 80 default_server;
listen [::]:80 default_server ipv6only=on;
root /var/www/example.com;
index index.html;
# Make site accessible from http://example.com/
server_name example.com;
location = / { proxy_pass http://127.0.0.1:8080/; }
location /archives { proxy_pass http://127.0.0.1:8080/archives; }
location /feed { proxy_pass http://127.0.0.1:8080/feed; }
location /search { proxy_pass http://127.0.0.1:8080/search; }
location /tags { proxy_pass http://127.0.0.1:8080/tags; }
location /debug { proxy_pass http://127.0.0.1:8080/debug; }
location /admin { proxy_pass http://127.0.0.1:8080/admin; }
location / {
# First attempt to serve request as file, then
# as directory, then fall back to displaying a 404.
try_files $uri $uri/ =404;
}
}

22
tekuti/cache.scm
View file

@ -72,17 +72,21 @@
(lambda (request)
(and (equal? (request-uri request) uri)
(eq? (request-method request) method)
(let ((last-modified (response-last-modified response))
(let ((request-etags (request-if-none-match request))
(since (request-if-modified-since request)))
(if (and last-modified since)
(and
;; Only return a 304 if the request is conditional.
(or request-etags since)
;; If the request specifies an etag set, honor it.
(or (not request-etags)
(and (list? request-etags)
(member (response-etag response) request-etags)))
;; Likewise for if-modified-since.
(or (not since)
(let ((last-modified (response-last-modified response)))
(and last-modified
(time<=? (date->time-utc last-modified)
(date->time-utc since))
#t))
(let ((etag (response-etag response))
(match (request-if-none-match request)))
(if (and etag match)
(and (list? match) (member etag match))
#t))
(date->time-utc since)))))))
(cons response body))))
((200)
(lambda (request)

313
tekuti/classifier.scm Normal file
View file

@ -0,0 +1,313 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2012 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;; Commentary:
;;
;; Comments -- pulling them out of the database, and making new ones.
;;
;;; Code:
(define-module (tekuti classifier)
#:use-module (tekuti comment)
#:use-module (tekuti filters)
#:use-module (tekuti git)
#:use-module (tekuti util)
#:use-module (ice-9 match)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-9)
#:export (reindex-legit-comments
reindex-bogus-comments
reindex-classifier
comment-is-bogus?))
(define (tokenize-comment comment)
(define (decorate-tokens decorator tokens)
(map (lambda (token) (string-append decorator token)) tokens))
(define (tokenize exp)
(match exp
((or () #f) '())
((? string?) (string-tokenize exp char-set:letter+digit))
(((or 'comment 'div 'p) . body)
(tokenize body))
(((? symbol? tag) . body)
(decorate-tokens (string-append (symbol->string tag) ".")
(tokenize body)))
((head . tail) (append (tokenize head) (tokenize tail)))
(_ (pk 'what exp comment) '())))
(tokenize
`(comment
(author ,(assq-ref comment 'author))
(email ,(assq-ref comment 'author_email))
(url ,(assq-ref comment 'author_url))
,(let ((format (or (assq-ref comment 'format) 'wordpress))
(raw (assq-ref comment 'raw-content)))
(or (case format
((wordpress) (false-if-exception (wordpress->sxml raw)))
(else `(pre ,raw)))
`(pre ,raw))))))
(define (fold-features comment f seed)
(let lp ((tokens (tokenize-comment comment)) (seed seed))
(define (make-3-gram a b c)
(string-append a " " (or b "") " " (or c "")))
(define (make-2-gram a b)
(string-append a " " (or b "")))
(define (make-1-gram a)
a)
(match tokens
((a . tokens)
(lp tokens
(or (f (match tokens
((b c . _) (make-3-gram a b c))
((b) (make-3-gram a b #f))
(() (make-3-gram a #f #f)))
(or (f (match tokens
((b . _) (make-2-gram a b))
(() (make-2-gram a #f)))
(f (make-1-gram a)
seed))
seed))
(f (make-1-gram a)
seed))))
(() seed))))
(define (count-features comments)
(let ((counts (make-hash-table)))
(hash-for-each
(lambda (comment-sha1 comment-name)
(fold-features (blob->comment comment-name comment-sha1)
(lambda (feature counts)
(add-feature! counts feature)
counts)
counts))
comments)
counts))
;; A feature's bogosity is the probability that a bogus document
;; contains that feature, divided by the probability that a legit
;; document contains the feature.
(define (compute-log-bogosities legit-features bogus-features)
(define (feature-count table)
(hash-fold (lambda (feature count sum) (+ count sum)) 0 table))
(let ((total-bogus-features (feature-count bogus-features))
(total-legit-features (feature-count legit-features))
(log-bogosities (make-hash-table)))
(hash-for-each
(lambda (feature bogus-count)
(let ((legit-count (hash-ref legit-features feature 0)))
(hash-set! log-bogosities feature
(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
(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))
(define (update-bogosities! log-bogosities changed-features
legit-features bogus-features)
(define (feature-count table)
(hash-fold (lambda (feature count sum) (+ count sum)) 0 table))
(let ((total-bogus-features (feature-count bogus-features))
(total-legit-features (feature-count legit-features)))
(hash-for-each
(lambda (feature _)
(let ((bogus-count (hash-ref bogus-features feature 0))
(legit-count (hash-ref legit-features feature 0)))
(hash-set! log-bogosities feature
(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))))
changed-features)))
(define (compute-bogus-probability comment log-bogosities bogus-prior
feature-limit)
(let ((v (make-vector feature-limit 0.0)))
(define (add-bogosity! log-bogosity)
(let ((mag (abs log-bogosity)))
(when (< (abs (vector-ref v 0)) mag)
(let lp ((idx 0))
(let ((next (1+ idx)))
(cond
((and (< next (vector-length v))
(< (abs (vector-ref v next)) mag))
(vector-set! v idx (vector-ref v next))
(lp (1+ idx)))
(else
(vector-set! v idx log-bogosity))))))))
(fold-features comment
(lambda (feature _)
(add-bogosity! (hash-ref log-bogosities feature 0.0)))
#f)
(let* ((ratio (exp (+ (log (/ bogus-prior (- 1.0 bogus-prior)))
(apply + (vector->list v))))))
(/ ratio (+ ratio 1.0)))))
(define (compute-differing-comments old-master new-master)
;; sha1 -> name
(define (compute-hash-diff old new)
(let ((removed (make-hash-table))
(added (make-hash-table)))
(hash-for-each (lambda (post-sha1 post-name)
(unless (hash-ref new post-sha1)
(hash-set! removed post-sha1 post-name)))
old)
(hash-for-each (lambda (post-sha1 post-name)
(unless (hash-ref old post-sha1)
(hash-set! added post-sha1 post-name)))
new)
(values removed added)))
(define* (git-ls-tree->hash ref kind #:optional (out (make-hash-table)))
(for-each
(match-lambda
((name sha1 (? (lambda (x) (eq? x kind))))
(hash-set! out sha1 name)))
(git-ls-tree ref #f))
out)
(let ((old-post-trees (git-ls-tree->hash old-master 'tree))
(new-post-trees (git-ls-tree->hash new-master 'tree)))
(let-values (((removed-post-trees added-post-trees)
(compute-hash-diff old-post-trees new-post-trees)))
(let ((old-comments (make-hash-table))
(new-comments (make-hash-table)))
(hash-for-each
(lambda (sha1 name)
(git-ls-tree->hash (string-append sha1 ":comments") 'blob
old-comments))
removed-post-trees)
(hash-for-each
(lambda (sha1 name)
(git-ls-tree->hash (string-append sha1 ":comments") 'blob
new-comments))
added-post-trees)
(compute-hash-diff old-comments new-comments)))))
(define (reindex-legit-comments old-index index)
(let ((old-legit-comments (assq-ref old-index 'legit-comments))
(old-master (assq-ref old-index 'master))
(new-master (assq-ref index 'master)))
(if old-legit-comments
(let-values (((removed added)
(compute-differing-comments old-master new-master)))
(hash-for-each (lambda (k v)
(hash-remove! old-legit-comments k))
removed)
(hash-for-each (lambda (k v)
(hash-set! old-legit-comments k v))
added)
old-legit-comments)
(compute-legit-comments new-master))))
(define (reindex-bogus-comments old-index index)
(let ((old-bogus-comments (assq-ref old-index 'bogus-comments))
(old-classifier (assq-ref old-index 'classifier))
(old-master (assq-ref old-index 'master))
(new-master (assq-ref index 'master)))
(if old-bogus-comments
(let-values (((removed added)
(compute-differing-comments old-master new-master)))
(hash-for-each (lambda (k v)
(hash-remove! old-bogus-comments k))
added)
(hash-for-each (lambda (k v)
(hash-set! old-bogus-comments k v))
removed)
old-bogus-comments)
(compute-bogus-comments new-master (assq-ref index 'legit-comments)))))
(define-record-type <classifier>
(make-classifier legit-prior legit-features bogus-features bogosities)
classifier?
(legit-prior classifier-legit-prior)
(legit-features classifier-legit-features)
(bogus-features classifier-bogus-features)
(bogosities classifier-bogosities))
(define (rebuild-classifier legit-comments bogus-comments)
(format #t "Rebuilding bogus comment classifier...\n")
(with-time-debugging
(let* ((legit-count (hash-count (const #t) legit-comments))
(bogus-count (hash-count (const #t) bogus-comments))
(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)))
(make-classifier legit-prior legit-features bogus-features bogosities))))
(define* (add-feature! features feature #:optional (count 1))
(let ((h (hash-create-handle! features feature 0)))
(set-cdr! h (+ (cdr h) count))))
(define* (remove-feature! features feature #:optional (count 1))
(let ((h (hash-get-handle features feature)))
(when h
(set-cdr! h (- (cdr h) count)))))
(define (reindex-classifier old-index index)
(match (assq-ref old-index 'classifier)
(#f
(rebuild-classifier (assq-ref index 'legit-comments)
(assq-ref index 'bogus-comments)))
((and classifier
($ <classifier> legit-prior legit-features bogus-features bogosities))
(let-values (((removed added)
(compute-differing-comments (assq-ref old-index 'master)
(assq-ref index 'master))))
(let ((removed-features (count-features removed))
(added-features (count-features added)))
(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))
added-features)
(update-bogosities! bogosities removed-features
legit-features bogus-features)
(update-bogosities! bogosities added-features
legit-features bogus-features)))
classifier)))
(define* (comment-bogus-probability classifier comment #:key (feature-limit 20))
(let* ((log-bogosities (classifier-bogosities classifier))
(bogus-prior (- 1.0 (classifier-legit-prior classifier))))
(compute-bogus-probability comment log-bogosities
bogus-prior feature-limit)))
(define* (comment-is-bogus? index comment #:key (threshold 0.5))
(let ((classifier (assq-ref index 'classifier)))
(> (comment-bogus-probability classifier comment) threshold)))

94
tekuti/comment.scm
View file

@ -30,13 +30,15 @@
#:use-module (tekuti util)
#:use-module (tekuti filters)
#:use-module (tekuti post)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (sxml transform)
#:use-module (tekuti match-bind)
#:export (blob->comment comment-sxml-content comment-timestamp
comment-readable-date bad-new-comment-post?
make-new-comment delete-comment))
parse-new-comment make-new-comment delete-comment
compute-legit-comments compute-bogus-comments))
(define *comment-spec*
`((timestamp . ,string->number)))
@ -64,6 +66,16 @@
(define (comment-raw-content comment)
(assq-ref comment 'raw-content))
(define (neutralize-links sxml)
(pre-post-order
sxml
`((a . ,(lambda sxml
(match sxml
(('a ('@ . attrs) . body)
`(a (@ (rel "external nofollow") . ,attrs) . ,body)))))
(*default* . ,(lambda sxml sxml))
(*text* . ,(lambda (tag text) text)))))
(define (comment-sxml-content comment)
`(li (@ (class "alt") (id ,(assq-ref comment 'key)))
(cite ,(let ((url (assq-ref comment 'author_url))
@ -75,11 +87,12 @@
(small (@ (class "commentmetadata"))
(a (@ (href ,(string-append "#" (assq-ref comment 'key))))
,(comment-readable-date comment)))
,(let ((format (or (assq-ref comment 'format) 'wordpress)))
,(neutralize-links
(let ((format (or (assq-ref comment 'format) 'wordpress)))
((case format
((wordpress) wordpress->sxml)
(else (lambda (text) `(pre ,text))))
(comment-raw-content comment)))))
(comment-raw-content comment))))))
(define (comment-timestamp comment-alist)
(or (assq-ref comment-alist 'timestamp) #f))
@ -95,10 +108,12 @@
`(p "Bad URL. (Only http and https are allowed.)")))
(define (bad-number? x)
(if (string->number x)
(match (string->number x)
(#f '(p "Bad number. Give me something that Scheme's "
(tt "string->number") " will like."))
(n (if (and (real? n) (<= 34 n 42))
#f
'(p "Bad number. Give me something that Scheme's "
(tt "string->number") " will like.")))
'(p "Number not between 34 and 42.")))))
(define *new-comment-spec*
`(("author" ,(lambda (x) #f))
@ -123,22 +138,29 @@
(define de-newline (s///g "[\n\r]" " "))
(define (make-new-comment key title post-data)
(define (parse-new-comment post-data)
(let ((content (assoc-ref post-data "comment"))
(author (assoc-ref post-data "author"))
(email (assoc-ref post-data "email"))
(url (assoc-ref post-data "url")))
(let ((sha1 (with-output-to-blob
(for-each
(lambda (pair)
(format #t "~a: ~a\n" (car pair) (cdr pair)))
`((timestamp . ,(time-second (current-time)))
(author . ,(de-newline author))
(author_email . ,email)
(author_url . ,url)))
(author_url . ,url)
(raw-content . ,content))))
(define (make-new-comment key title comment)
(let ((sha1 (with-output-to-blob
(for-each
(match-lambda
((k . v)
(unless (eq? k 'raw-content)
(format #t "~a: ~a\n" k v))))
comment)
(display "\n")
(display content)))
(message (format #f "comment on \"~a\" by ~a" title author)))
(display (assq-ref comment 'raw-content))))
(message (format #f "comment on \"~a\" by ~a" title
(assq-ref comment 'author))))
(git-update-ref
"refs/heads/master"
(lambda (master)
@ -147,7 +169,7 @@
(list key "comments")
(list sha1 sha1 'blob))
master message #f))
5))))
5)))
(define (delete-comment post id)
(let ((key (post-key post))
@ -160,3 +182,45 @@
`(,id))
master message #f))
5)))
(define (compute-legit-comments master-ref)
;; sha1 -> #t
(define legit (make-hash-table))
(pk 'computing-legit)
(for-each
(match-lambda
((post-name post-sha1 'tree)
(for-each
(match-lambda
((comment-name comment-sha1 'blob)
(hash-set! legit comment-sha1 comment-name)))
(git-ls-tree (string-append post-sha1 ":comments") #f))))
(git-ls-tree master-ref #f))
(pk 'done legit))
(define (compute-bogus-comments master-ref legit)
;; sha1 -> #t
(define visited-trees (make-hash-table))
(define bogus (make-hash-table))
(pk 'computing-bogus)
(fold-commits
(lambda (rev commit _)
(pk 'computing-bogus rev)
(for-each
(match-lambda
((post-name post-sha1 'tree)
(unless (hash-ref visited-trees post-sha1)
(hash-set! visited-trees post-sha1 #t)
(for-each
(match-lambda
((comment-name comment-sha1 'blob)
(unless (or (hash-ref legit comment-sha1)
(hash-ref bogus comment-sha1))
(hash-set! bogus comment-sha1 comment-name)))
(_ #f))
(git-ls-tree (string-append post-sha1 ":comments") #f))))
(_ #f))
(git-ls-tree (assq-ref commit 'tree) #f)))
(assq-ref (parse-commit master-ref) 'parent)
#f)
bogus)

20
tekuti/config.scm
View file

@ -1,5 +1,5 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2012 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2008, 2010, 2012, 2014, 2021 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -27,13 +27,14 @@
(define-module (tekuti config)
#:use-module (tekuti util)
#:use-module ((sxml ssax) #:select (define-parsed-entity!))
#:export (*public-host* *public-port* *public-path-base*
#:export (*public-scheme* *public-host* *public-port* *public-path-base*
*private-host* *private-port* *private-path-base*
*git-dir* *git* *debug* *admin-user* *admin-pass*
*css-file* *navbar-links* *navbar-infix*
*title* *subtitle* *name*
*title* *subtitle* *name* *comments-open-window*
*server-impl* *server-impl-args*))
(define *public-scheme* 'http)
(define *public-host* "127.0.0.1")
(define *public-port* 8080)
(define *public-path-base* '())
@ -53,14 +54,15 @@
(define *title* "My blog")
(define *subtitle* "Just a blog, ok")
(define *name* "Joe Schmo")
(define *comments-open-window* (* 60 60 24 21))
(define *server-impl* 'http)
(define *server-impl-args*
(lambda () `(#:host ,*private-host* #:port ,*private-port*)))
(define-parsed-entity! 'agrave 224)
(define-parsed-entity! 'laquo 171)
(define-parsed-entity! 'mdash 8212)
(define-parsed-entity! 'nbsp 160)
(define-parsed-entity! 'raquo 187)
(define-parsed-entity! 'uacute 250)
(define-parsed-entity! 'agrave (string (integer->char 224)))
(define-parsed-entity! 'laquo (string (integer->char 171)))
(define-parsed-entity! 'mdash (string (integer->char 8212)))
(define-parsed-entity! 'nbsp (string (integer->char 160)))
(define-parsed-entity! 'raquo (string (integer->char 187)))
(define-parsed-entity! 'uacute (string (integer->char 250)))

22
tekuti/git.scm
View file

@ -1,5 +1,5 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2008, 2010, 2011, 2012, 2017 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -27,6 +27,7 @@
(define-module (tekuti git)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (tekuti util)
#:use-module (tekuti config)
#:use-module (tekuti match-bind)
@ -44,6 +45,7 @@
git-commit-tree git-rev-list git-revert
munge-tree munge-tree1 parse-commit commit-utc-timestamp
fold-commits
with-output-to-blob with-input-from-blob))
@ -77,7 +79,7 @@
(define (prepend-env args)
(if (null? env)
args
(cons "/usr/bin/env" (append env args))))
(cons "env" (append env args))))
(define (redirect-input args)
(if input-file
(list "/bin/sh" "-c"
@ -86,11 +88,7 @@
args))
(let* ((real-args (trc (redirect-input (prepend-env args))))
(pipe (apply open-pipe* OPEN_READ real-args))
(output (begin
(let ((bv (get-bytevector-all pipe)))
(if (eof-object? bv)
""
(utf8->string bv)))))
(output (get-string-all pipe))
(ret (close-pipe pipe)))
(case (status:exit-val ret)
((0) output)
@ -171,7 +169,7 @@
(let ((s (string-trim-both (call-with-input-file rev read-line))))
(and (= (string-length s) 40)
s)))
(git "rev-parse" rev)))
(string-trim-both (git "rev-parse" rev))))
(define (git-rev-list rev n)
(let lp ((lines (string-split
@ -335,6 +333,14 @@
"^([^ ]+) (.*)$" (_ k v)
(cons (string->symbol k) v))))))
(define (fold-commits f rev seed)
(let lp ((rev (and rev (git-rev-parse rev))) (seed seed))
(if rev
(let ((commit (parse-commit rev)))
(lp (assq-ref commit 'parent)
(f rev commit seed)))
seed)))
(define (commit-utc-timestamp commit)
(match-bind
"^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer)

85
tekuti/index.scm
View file

@ -25,6 +25,7 @@
;;; Code:
(define-module (tekuti index)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (system repl error-handling)
#:use-module (tekuti util)
@ -32,46 +33,48 @@
#:use-module (tekuti post)
#:use-module (tekuti tags)
#:use-module (tekuti cache)
#:use-module (tekuti classifier)
#:export (maybe-reindex read-index update-index))
;; Additionally an index has an "index" field, indicating the commit
;; that it was saved in, and a "master" field, indicating the commit
;; that it indexes.
(define index-specs
`((posts ,reindex-posts ,write-hash ,read-hash)
`((master #f ,write ,read)
(posts ,reindex-posts ,write-hash ,read-hash)
(posts-by-date ,reindex-posts-by-date ,write ,read)
(tags ,reindex-tags ,write-hash ,read-hash)
(cache ,(lambda _ (make-empty-cache)) ,(lambda (x) #f) ,(lambda () '()))))
(legit-comments ,reindex-legit-comments ,write-hash ,read-hash)
(bogus-comments ,reindex-bogus-comments ,write-hash ,read-hash)
(classifier ,reindex-classifier #f #f)
(cache ,(lambda _ (make-empty-cache)) #f #f)))
(define (reindex oldindex master)
;; Leave off "index" field.
(with-time-debugging
(fold (lambda (pair index)
(acons (car pair) ((cadr pair) oldindex index)
index))
(fold (lambda (spec index)
(match spec
((key reindex write read)
(acons key (with-time-debugging (begin (pk key) (reindex oldindex index))) index))))
(acons 'master master '())
index-specs)))
(define (assoc-list-ref alist key n default)
(let ((l (assoc key alist)))
(if l (list-ref l n) default)))
(define (index->blob key value)
(with-output-to-blob
((assoc-list-ref index-specs key 2 write) value)))
(define (blob->index name sha1)
(with-input-from-blob
sha1
((assoc-list-ref index-specs (string->symbol name) 3 read))))
;; Skip past "master" as we handle that one specially.
(match index-specs
((('master . _) . specs) specs)))))
(define (write-index index oldref)
(let ((new (git-commit-tree
(git-mktree
(let lp ((index index))
(cond
((null? index) '())
((eq? (caar index) 'index) (lp (cdr index)))
(else (cons (list (caar index)
(index->blob (caar index) (cdar index))
'blob)
(lp (cdr index)))))))
(match index
(() '())
(((k . v) . index)
(match (assq k index-specs)
((_ reindex write read)
(if write
(cons (list k (with-output-to-blob (write v)) 'blob)
(lp index))
(lp index)))
(_ (lp index)))))))
oldref "reindex\n"
(commit-utc-timestamp (assq-ref index 'master)))))
(or (false-if-git-error
@ -80,16 +83,26 @@
new))
(define (read-index)
(let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index")))
(dents (if ref (git-ls-tree ref #f) '())))
(acons 'index ref
(and (and-map (lambda (spec)
(assoc (symbol->string (car spec)) dents))
index-specs)
(map (lambda (dent)
(cons (string->symbol (car dent))
(blob->index (car dent) (cadr dent))))
dents)))))
(pk 'reading-index)
(match (false-if-git-error (git-rev-parse "refs/heads/index"))
(#f (maybe-reindex '()))
(ref
(let ((dents (git-ls-tree ref #f)))
(fold (lambda (spec index)
(match spec
((key reindex write read)
(pk 'read-index-key key)
(acons key
(cond
((and read (assoc (symbol->string key) dents))
=> (match-lambda
((_ sha1 'blob)
(with-input-from-blob sha1 (read)))))
(else
(reindex '() index)))
index))))
`((index . ,ref))
index-specs)))))
(define (maybe-reindex old-index)
(let ((master (git-rev-parse "refs/heads/master")))

240
tekuti/page-helpers.scm
View file

@ -1,5 +1,5 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2012 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2008, 2010, 2012, 2014, 2019, 2021 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -25,6 +25,7 @@
;;; Code:
(define-module (tekuti page-helpers)
#:use-module (ice-9 match)
#:use-module (sxml simple)
#:use-module (web uri)
#:use-module (web http)
@ -37,6 +38,7 @@
#:use-module (tekuti comment)
#:use-module (tekuti request)
#:use-module (tekuti template)
#:use-module ((srfi srfi-1) #:select (append-map))
#:use-module (srfi srfi-19)
#:export (respond
relurl rellink
@ -49,10 +51,7 @@
find-posts-matching
atom-header atom-entry))
(define xhtml-doctype
(string-append
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
(define html-doctype "<!doctype html>\n")
(define-syntax build-headers
(syntax-rules ()
@ -65,30 +64,196 @@
((_ tail)
tail)))
(define (ensure-public-uri x)
(define (ensure-uri x)
(cond
((uri? x) x)
((string? x)
(build-uri 'http #:host *public-host* #:port *public-port* #:path x))
(build-uri *public-scheme* #:host *public-host* #:port *public-port*
#:path x))
((list? x)
(ensure-public-uri (relurl x)))
(ensure-uri (relurl x)))
(else (error "can't turn into a uri" x))))
(define (ensure-uri-reference x)
(cond
((uri? x) x)
((string? x)
(if (defined? 'build-uri-reference)
(build-uri-reference #:path x)
;; Absolute URIs on older Guile.
(ensure-uri x)))
((list? x)
(ensure-uri-reference (relurl x)))
(else (error "can't turn into a uri" x))))
(define-syntax-rule (define-tag-set pred tag ...)
(define pred
(let ((set (make-hash-table)))
(hashq-set! set 'tag #t) ...
(lambda (t) (hashq-ref set t)))))
(define-tag-set void-element?
area base br col embed hr img input link meta param source track wbr)
(define-tag-set template-element?
template)
(define-tag-set raw-text-element?
script style)
(define-tag-set escapable-raw-text-element?
textarea title)
(define (foreign-element? tag)
(string-index (symbol->string tag) #\:))
;; Otherwise it's a normal element.
(define (make-char-quotator char-encoding)
(let ((bad-chars (list->char-set (map car char-encoding))))
;; Check to see if str contains one of the characters in charset,
;; from the position i onward. If so, return that character's index.
;; otherwise, return #f
(define (index-cset str i charset)
(string-index str charset i))
;; The body of the function
(lambda (str port)
(let ((bad-pos (index-cset str 0 bad-chars)))
(if (not bad-pos)
(display str port) ; str had all good chars
(let loop ((from 0) (to bad-pos))
(cond
((>= from (string-length str)) *unspecified*)
((not to)
(display (substring str from (string-length str)) port))
(else
(let ((quoted-char
(cdr (assv (string-ref str to) char-encoding)))
(new-to
(index-cset str (+ 1 to) bad-chars)))
(if (< from to)
(display (substring str from to) port))
(display quoted-char port)
(loop (1+ to) new-to))))))))))
(define (attribute-value-empty? value)
(string-null? value))
(define attribute-value-needs-quotes-chars
(char-set-union (string->char-set "\"'=<>`") char-set:whitespace))
(define (attribute-value-needs-quotes? value)
(or (string-null? value)
(string-index value attribute-value-needs-quotes-chars)))
(define print-attribute-value/quoted
(make-char-quotator
'((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
(define print-text/quoted
(make-char-quotator
'((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;"))))
(define* (shtml->html tree #:optional (port (current-output-port)))
"Serialize the shtml tree @var{tree} as HTML. The output will be written
to the current output port, unless the optional argument @var{port} is
present."
(define (attribute->html attr value)
(display attr port)
(unless (attribute-value-empty? value)
(display #\= port)
(cond
((attribute-value-needs-quotes? value)
(display #\" port)
(print-attribute-value/quoted value port)
(display #\" port))
(else
(display value port)))))
(define (element->html tag attrs body)
(display #\< port)
(display tag port)
(let lp ((attrs attrs))
(match attrs
(() #t)
((((? symbol? attr) val) . attrs)
(display #\space port)
(attribute->html attr val)
(lp attrs))))
(cond
((and (null? body) (foreign-element? tag))
(display " />" port))
((void-element? tag)
(unless (null? body) (error "unexpected body for void element"))
(display #\> port))
(else
(display #\> port)
(cond
((raw-text-element? tag)
(let ((body (string-concatenate body)))
(let ((needle (string-append "</" (symbol->string tag))))
(let lp ((idx 0))
(let ((idx (string-contains-ci body needle idx)))
(when idx
(let ((idx (+ idx (string-length needle))))
(let ((ch (and (< idx (string-length body))
(string-ref body idx))))
(when (and ch (string-index "\t\n\f\r >/" ch))
(error "raw text element body contains end tag"
needle body)))
(lp idx))))))
(display body port)))
((escapable-raw-text-element? tag)
(for-each
(lambda (str)
(unless (string? str)
(error "bad escapable raw text content" str))
(print-text/quoted str port))
body))
(else
(for-each ->html body)))
(display "</" port)
(display tag port)
(display ">" port))))
(define (->html tree)
(match tree
(((? symbol? tag) ('@ . attrs) . body)
(element->html tag attrs body))
(((? symbol? tag) . body)
(element->html tag '() body))
((_ . _)
(error "nodelists unsupported" tree))
((or #f #t ()) #f)
((? string?)
(print-text/quoted tree port))
((? procedure?)
(with-output-to-port port tree))
((? number?)
(display tree port))
(tree
(error "unexpected shtml" tree))))
(match tree
(('html . _)
(->html tree))))
(define* (respond #:optional body #:key
redirect
(status (if redirect 302 200))
(title *title*)
last-modified
etag
(doctype xhtml-doctype)
(doctype html-doctype)
(content-type-params '((charset . "utf-8")))
(content-type 'text/html)
(extra-headers '())
(serialize
(match content-type
('text/html shtml->html)
('application/atom+xml sxml->xml)))
(sxml (and body (templatize #:title title #:body body))))
(values (build-response
#:code status
#:headers (build-headers
location (and=> redirect ensure-public-uri)
location (and=> redirect ensure-uri-reference)
last-modified last-modified
content-type (cons content-type content-type-params)
date (current-date)
@ -97,7 +262,7 @@
(and sxml
(lambda (port)
(if doctype (display doctype port))
(sxml->xml sxml port)))))
(serialize sxml port)))))
(define (unparse-www-form-urlencoded alist)
(string-join (map (lambda (pair)
@ -164,7 +329,7 @@
""))))
(label (@ (for "tags")) " <- tags, comma-separated"))
(p (input (@ (name "date") (type "text")
(value ,(if (and=> post post-published?)
(value ,(if (and=> post post-public?)
(timestamp->rfc822-date (post-timestamp post))
""))))
(label (@ (for "date")) " <- date (empty == now)"))
@ -172,24 +337,51 @@
,@(if (or (not post) (post-comments-open? post))
`((checked "checked")) '())))
(label (@ (for "comments")) " comments open?"))
(p (input (@ (name "comments-closed-date") (type "text")
(value ,(or (and=> (and=> post
post-comments-closed-timestamp)
timestamp->rfc822-date)
""))))
(label (@ (for "comments-closed-date"))
" <- close comments on date (empty == in "
,(floor/ *comments-open-window* (* 24 60 60))
" days)"))
(div (textarea (@ (name "body") (rows "20") (cols "60"))
,(if post (post-raw-content post) "")))
(input (@ (type "submit") (name "status")
(value "publish")))
" "
(input (@ (type "submit") (name "status")
(value "draft"))))
(p (label (input (@ (type "radio") (name "status") (value "private")
,@(if (or (not post) (post-private? post))
'((checked "checked"))
'())))
"private (only visible to admin)") (br)
(label (input (@ (type "radio") (name "status") (value "draft")
,@(if (and post (post-draft? post))
'((checked "checked"))
'())))
"draft (only accessible via "
,(if post
`(a (@ (href ,(post-url post)))
,(post-url post))
"direct link")
")")
(br)
(label (input (@ (type "radio") (name "status") (value "publish")
,@(if (and post (post-public? post))
'((checked "checked"))
'())))
"public"))
(p (input (@ (type "submit")
(value ,(if post "modify post" "new post"))))))
,@(if post
`((form (@ (method "POST")
(action ,(relurl `("admin" "delete-post" ,(post-key post)))))
" "
(input (@ (type "submit") (name "delete") (value "delete"))))
(p (input (@ (type "submit") (value "delete post")))))
,@(let ((l (comments-sxml-content-edit post)))
(if (null? l) l
`((h2 "comments")
(ol (@ (class "commentlist")) ,@l))))
(h2 "preview")
,(show-post post #f))
,@(show-post post #f))
'())))
(define (sidebar-ul body)
@ -226,7 +418,7 @@
" " (label (@ (for "url")) (small "Website")))
(p (input (@ (type "text") (name "x") (value "")
(size "22") (tabindex "3")))
" " (label (@ (for "x")) (small "What's your favorite number?")))
" " (label (@ (for "x")) (small "What's a number between 34 and 42?")))
;(p (small "allowed tags: "))
(p (textarea (@ (name "comment") (id "comment") (cols "65")
(rows "10") (tabindex "4"))
@ -235,7 +427,7 @@
(value "Submit Comment"))))))
(define (comments-sxml-content-edit post)
(map
(append-map
(lambda (comment)
(let ((id (assq-ref comment 'key)))
`(,(comment-sxml-content comment)
@ -388,7 +580,7 @@
(define (atom-header last-modified)
(define (relurl . tail)
(uri->string (ensure-public-uri tail)))
(uri->string (ensure-uri tail)))
`(feed
(@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl)))
(title (@ (type "text")) ,*title*)
@ -407,7 +599,7 @@
(define (atom-entry post)
(define (relurl . tail)
(uri->string (ensure-public-uri tail)))
(uri->string (ensure-uri tail)))
`(entry
(author (name ,*name*) (uri ,(relurl)))
(title (@ (type "text")) ,(post-title post))

38
tekuti/page.scm
View file

@ -1,5 +1,5 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2008, 2010, 2011, 2012, 2019, 2021 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -30,11 +30,12 @@
#:use-module (tekuti git)
#:use-module (tekuti post)
#:use-module (tekuti comment)
#:use-module (tekuti classifier)
#:use-module (web uri)
#:use-module (web request)
#:use-module (tekuti request)
#:use-module (tekuti page-helpers)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((srfi srfi-1) #:select (fold append-map))
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-19)
#:export (page-admin
@ -61,7 +62,7 @@
;; Encoded twice, so as to form a single path-component.
(define (make-post-key . parts)
(uri-encode (encode-and-join-uri-path parts)))
(string-downcase (uri-encode (encode-and-join-uri-path parts))))
(define (not-implemented request . args)
(respond `((h1 "Not yet implemented")
@ -88,7 +89,7 @@
(ul ,@(post-links 5)))
(li (h2 "changes" ,(rellink '("admin" "changes")
">>"))
(ul ,(recent-changes 5)))))
(ul ,@(recent-changes 5)))))
(h2 "new post")
,(post-editing-form #f))))))
@ -186,17 +187,18 @@
(define (page-index request body index)
(respond `(,(main-sidebar request index)
,@(map (lambda (post)
. ,(append-map (lambda (post)
(show-post post #f))
(latest-posts index #:limit 10)))
#:etag (assq-ref index 'master)))
(define (page-show-post request body index year month day post)
(cond
((post-from-key index (make-post-key year month day post))
((post-from-key index (make-post-key year month day post)
#:allow-draft? #t)
=> (lambda (post)
(respond `(,(post-sidebar post index)
,(show-post post #t))
,@(show-post post #t))
#:title (string-append (post-title post) " -- " *title*)
#:etag (assq-ref index 'master))))
(else
@ -207,13 +209,29 @@
(cond
((post-from-key index (make-post-key year month day name))
=> (lambda (post)
(let ((comment (parse-new-comment data)))
(cond
((not (post-comments-open? post))
(respond `((p "Comments on this post are closed."))))
((bad-new-comment-post? data)
=> (lambda (reason)
(respond `((p "Bad post data: " ,(pk reason))))))
((comment-is-bogus? index comment)
(respond `((p "Comment appears to be bogus; ignoring.")
(p "I'm testing out a new automated bogus "
"comment detector. If you feel your comment "
"was caught unfairly, tweet it to me or send "
"it by email. Or press back and reword it.")
(p "If you are a spammer, note that I fixed "
"the comment renderer to properly add "
(tt "rel='external nofollow'") " on all "
"links in comments. Go take a look at any "
"comment with a link to see for yourself. "
"Trying to linkbomb this site probably won't "
"give you any link juice so it's not worth "
"the trouble to either one of us :)"))))
(else
(let ((comment (make-new-comment (post-key post) (post-title post)
data)))
(make-new-comment (post-key post) (post-title post) comment)
;; nb: at this point, `post' is out-of-date
(respond `((p "Comment posted, thanks."))
#:redirect (post-url post #:fragment "comments")
@ -318,7 +336,7 @@
(post-timestamp (car posts)))))
(cond
((let ((since (request-if-modified-since request)))
(and since (>= (date->timestamp since) last-modified)))
(and since last-modified (>= (date->timestamp since) last-modified)))
(respond #f #:status 304
#:last-modified (timestamp->date last-modified)
#:etag (assq-ref index 'master)))

62
tekuti/post.scm
View file

@ -1,5 +1,5 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2008, 2010, 2011, 2012, 2014, 2021 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -37,8 +37,10 @@
#:use-module (srfi srfi-19)
#:export (post-from-key
post-tags post-timestamp post-key post-published?
post-comments-open? post-comments
post-tags post-timestamp post-key
post-public? post-draft? post-private?
post-comments-open? post-comments-closed-timestamp
post-comments
post-sxml-content post-readable-date post-n-comments
post-raw-content
post-title
@ -56,7 +58,11 @@
(define *post-spec*
`((timestamp . ,string->number)
(tags . ,(lambda (v) (string-split/trimming v #\,)))
(title . ,identity)))
(title . ,identity)
(comments-closed-timestamp . ,(lambda (str)
(if (string-null? str)
#f
(string->number str))))))
(define (post-from-tree encoded-name sha1)
(append `((key . ,encoded-name)
@ -79,9 +85,11 @@
;;; pulling posts out of the index
;;;
(define* (post-from-key index key #:key allow-unpublished?)
(define* (post-from-key index key #:key allow-unpublished? allow-draft?)
(let ((post (hash-ref (assq-ref index 'posts) key)))
(if (and post (or (post-published? post) allow-unpublished?))
(if (and post (or (post-public? post)
(and (post-draft? post) allow-draft?)
allow-unpublished?))
post
#f)))
@ -89,9 +97,15 @@
;;; accessors
;;;
(define (post-published? post-alist)
(define (post-public? post-alist)
(equal? (assq-ref post-alist 'status) "publish"))
(define (post-draft? post-alist)
(equal? (assq-ref post-alist 'status) "draft"))
(define (post-private? post-alist)
(equal? (assq-ref post-alist 'status) "private"))
(define (post-timestamp post-alist)
(assq-ref post-alist 'timestamp))
@ -105,7 +119,15 @@
(assq-ref post 'title))
(define (post-comments-open? post)
(equal? (assq-ref post 'comment_status) "open"))
(and (equal? (assq-ref post 'comment_status) "open")
(cond
((post-comments-closed-timestamp post)
=> (lambda (at-timestamp)
(< (time-second (current-time)) at-timestamp)))
(else #t))))
(define (post-comments-closed-timestamp post)
(assq-ref post 'comments-closed-timestamp))
(define (post-raw-content post)
(git "show" (string-append (assq-ref post 'sha1) ":content")))
@ -141,8 +163,11 @@
(let ((metadata (with-output-to-blob
(for-each
(lambda (k)
(format #t "~a: ~a\n" k (assq-ref parsed k)))
'(timestamp tags status title name comment_status))))
(cond
((assq-ref parsed k)
=> (lambda (v) (format #t "~a: ~a\n" k v)))))
'(timestamp tags status title name comment_status
comments-closed-timestamp))))
(content (with-output-to-blob (display (assq-ref parsed 'body))))
(key (assq-ref parsed 'key))
(message (format #f "~a: \"~a\""
@ -184,22 +209,31 @@
(tags (assoc-ref post-data "tags"))
(status (assoc-ref post-data "status"))
(comments-open? (assoc-ref post-data "comments"))
(date-str (assoc-ref post-data "date")))
(let ((timestamp (if (string-null? date-str)
(date-str (assoc-ref post-data "date"))
(comments-closed-date-str (assoc-ref post-data "comments-closed-date")))
(let* ((timestamp (if (string-null? date-str)
(time-second (current-time))
(rfc822-date->timestamp date-str)))
(comments-closed-timestamp
(if (string-null? comments-closed-date-str)
(if (post-public? (acons 'status status '()))
(+ *comments-open-window* timestamp)
#f)
(rfc822-date->timestamp comments-closed-date-str)))
(name (title->name title)))
`((title . ,title)
(body . ,body)
(tags . ,tags)
(status . ,status)
(comment_status . ,(if comments-open? "open" "closed"))
(comments-closed-timestamp . ,comments-closed-timestamp)
(timestamp . ,timestamp)
(name . ,name)
(key . ,(uri-encode
(key . ,(string-downcase
(uri-encode
(string-append (date->string (timestamp->date timestamp)
"~Y/~m/~d/")
(uri-encode name))))))))
(uri-encode name)))))))))
(define (make-new-post post-data)
(munge-post #f (parse-post-data post-data)))

3
tekuti/template.scm
View file

@ -54,6 +54,7 @@
(head (title ,title)
(meta (@ (name "Generator")
(content "An unholy concoction of parenthetical guile")))
(meta (@ (name "viewport") (content "width=device-width")))
(link (@ (rel "stylesheet")
(type "text/css")
(media "screen")
@ -70,5 +71,5 @@
(div (@ (id "content")) ,@body)
(div (@ (id "footer"))
"powered by "
(a (@ (href "http://wingolog.org/software/tekuti/"))
(a (@ (href "//wingolog.org/software/tekuti/"))
"tekuti"))))))

7
tekuti/util.scm
View file

@ -1,5 +1,5 @@
;; Tekuti
;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2008, 2010, 2011, 2012, 2014 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -62,7 +62,7 @@
(define (urlish? x)
(let ((uri (string->uri x)))
(and uri
(memq (uri-scheme uri) '(http https))
(memq (uri-scheme uri) '(#f http https))
(uri-host uri)
#t)))
@ -103,7 +103,8 @@
(define (expanduser path)
(let ((parts (string-split path #\/)))
(if (eqv? (string-ref (car parts) 0) #\~)
(if (and (not (string-null? (car parts)))
(eqv? (string-ref (car parts) 0) #\~))
(let ((user (if (= (string-length (car parts)) 1)
(passwd:name (getpwuid (geteuid)))
(substring (car parts) 1))))