From 0280eb9bd0deed9864c9009cd57290acf5239fb2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 Feb 2008 22:14:42 +0100 Subject: more cleanups, xhtml sanitization thanks to MikeS, --repl --- tekuti/boot.scm | 12 +++++---- tekuti/comment.scm | 77 ++++++++++++++++++++++++++--------------------------- tekuti/git.scm | 32 ++++++++++++---------- tekuti/mod-lisp.scm | 5 ++-- tekuti/page.scm | 6 ++++- tekuti/util.scm | 13 ++++++++- 6 files changed, 82 insertions(+), 63 deletions(-) diff --git a/tekuti/boot.scm b/tekuti/boot.scm index 8f94fe6..e06713b 100644 --- a/tekuti/boot.scm +++ b/tekuti/boot.scm @@ -37,6 +37,7 @@ (define *option-grammar* '((gds) (usage) + (repl) (version (single-char #\v)) (help (single-char #\h)))) @@ -55,10 +56,7 @@ ;; krap code (define (parse-options args) - (let ((opts (getopt-long args '((gds) - (usage) - (version (single-char #\v)) - (help (single-char #\h)))))) + (let ((opts (getopt-long args *option-grammar*))) (if (or (option-ref opts 'usage #f) (option-ref opts 'help #f) (not (null? (option-ref (cdr opts) '() '())))) @@ -79,4 +77,8 @@ (define (boot args) (let ((options (parse-options args))) (ensure-git-repo) - (event-loop))) + (if (option-ref options 'repl #f) + (begin (make-thread event-loop) + (scm-style-repl)) + (event-loop)))) + diff --git a/tekuti/comment.scm b/tekuti/comment.scm index ee42d3a..670fc25 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -130,24 +130,30 @@ (define (compile-sxslt-rules tags) (define (ok . body) body) + (define (compile-attribute-rule rule) + (if (symbol? rule) + `(,rule . ,ok) + `(,(car rule) . ,(lambda (tag text) + (or ((cdr rule) text) + (throw 'bad-attr-value text)) + (list tag text))))) `(,@(map (lambda (spec) `(,(car spec) - ((@ (,@(map (lambda (attr) - (if (symbol? attr) - `(,attr . ,ok) - `(,(car attr) - . ,(lambda (tag text) - (or ((cdr attr) text) - (throw 'bad-attr-value text)) - (list tag text))))) - (cdr spec))) - . ,ok)) + ((@ *preorder* + . ,(let ((rules `((@ (,@(map compile-attribute-rule + (cdr spec)) + (*text* + . ,(lambda (tag text) text)) + (*default* + . ,(lambda (tag . body) + (throw 'bad-attr tag)))) + . ,ok)))) + (lambda tree + (pre-post-order tree rules))))) . ,ok)) *allowed-tags*) (*text* . ,(lambda (tag text) text)) - (@ . ,(lambda (tag text) - (throw 'bad-attr tag))) (*default* . ,(lambda (tag . body) (throw 'bad-tag tag))))) @@ -251,40 +257,33 @@ dadd) dents)))))) -(define (mutate-tree master add remove change message) - (let ((tree (make-tree-deep master add remove change))) - (string-trim-both - (git* `("commit-tree" ,tree "-p" ,master) #:input message - #:env '("GIT_COMMMITTER=tekuti"))))) +(define de-newline (s///g "[\n\r]" " ")) (define (make-new-comment post 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 (create-blob - (with-output-to-string - (lambda () - (for-each - (lambda (pair) - (format #t "~a: ~a\n" (car pair) (cdr pair))) - `((timestamp . ,(time-second (current-time))) - (author . ,(string-join - ;; security foo - (string-split author #\newline) - " ")) - (author_email . ,email) - (author_url . ,url))) - (display "\n") - (display content)))))) + (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))) + (display "\n") + (display content)))) (git-update-ref "refs/heads/master" (lambda (master) - (mutate-tree master - `(((,(assq-ref post 'key) "comments") . (,sha1 ,sha1 "blob" "100644"))) - '() - '() - "new comment")) + (git-commit-tree + (make-tree-deep master + `(((,(assq-ref post 'key) "comments") + . (,sha1 ,sha1 blob))) + '() + '()) + master + "new comment" + #f)) 5)))) - - diff --git a/tekuti/git.scm b/tekuti/git.scm index f6e45cb..723882a 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -39,9 +39,11 @@ git git* ensure-git-repo git-ls-tree git-ls-subdirs parse-metadata parse-commit commit-utc-timestamp commit-parents git-mktree git-rev-parse - create-blob git-update-ref + git-hash-object git-update-ref git-commit-tree + with-output-to-blob with-input-from-blob + write-indices read-indices)) (define-condition-type &git-condition &condition git-condition? @@ -53,17 +55,6 @@ `(,guard (c ((,git-condition? c) #f)) ,@body)) -(define (shell:quote str) - (with-output-to-string - (lambda () - (display #\') - (for-each (lambda (ch) - (if (eqv? ch #\') - (begin (display #\\) (display #\')) - (display ch))) - (string->list str)) - (display #\')))) - (define *debug* #f) (define (trc . args) (if *debug* @@ -202,10 +193,22 @@ (define (git-rev-parse rev) (string-trim-both (git "rev-parse" rev))) -(define (create-blob contents) +(define (git-hash-object contents) (string-trim-both (git* '("hash-object" "-w" "--stdin") #:input contents))) +(define (with-output-to-blob* thunk) + (git-hash-object (with-output-to-string thunk))) + +(define-macro (with-output-to-blob . forms) + `(,with-output-to-blob* (lambda () ,@forms))) + +(define (with-input-from-blob* sha1 thunk) + (with-input-from-string (git "show" sha1) thunk)) + +(define-macro (with-input-from-blob sha1 . forms) + `(,with-input-from-blob* ,sha1 (lambda () ,@forms))) + (define (git-update-ref refname proc count) (let* ((ref (git-rev-parse refname)) (commit (proc ref))) @@ -227,7 +230,8 @@ #:env (if timestamp (list "GIT_COMMMITTER=tekuti" (format #f "GIT_COMMITTER_DATE=~a +0100" timestamp) - (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp)))))) + (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp)) + (list "GIT_COMMMITTER=tekuti"))))) ;; fixme: map-pairs diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index 266350c..1ad775d 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -26,15 +26,14 @@ (define-module (tekuti mod-lisp) #:use-module (ice-9 rdelim) - #:use-module ((srfi srfi-1) #:select (fold)) #:use-module (tekuti config) #:use-module (tekuti util) - #:use-module (tekuti index) ; rev-parse + #:use-module (tekuti index) #:use-module (tekuti request) #:use-module (tekuti web) #:export (event-loop)) -;;; thought: ignore SIGPIPE, otherwise apache dying will kill us +;;; FIXME: ignore SIGPIPE, otherwise apache dying will kill us (define (read-headers socket) (define (read-line*) diff --git a/tekuti/page.scm b/tekuti/page.scm index a6c4758..0974935 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -271,7 +271,11 @@ (rcons* request 'title "comment posted" 'body `((p "Comment, posted, thanks.") - (p "Back to the post: " (post-link post))))))))) + ;; fixme: show the post directly; or a redirect? + (p "Back to the post: " + ,(rellink (string-append "archives/" (url:decode slug)) + post))))))))) + (else (page-not-found request index))))) diff --git a/tekuti/util.scm b/tekuti/util.scm index 35c0c78..2dd4240 100644 --- a/tekuti/util.scm +++ b/tekuti/util.scm @@ -29,9 +29,20 @@ #:use-module (srfi srfi-1) #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort hash-push! list-has-length? list-head-match mapn - take-max read-hash write-hash + take-max read-hash write-hash shell:quote list-intersperse with-backtrace with-time-debugging define-memoized)) +(define (shell:quote str) + (with-output-to-string + (lambda () + (display #\') + (string-for-each (lambda (ch) + (if (eqv? ch #\') + (begin (display #\\) (display #\')) + (display ch))) + str) + (display #\')))) + (define (expanduser path) (let ((parts (string-split path #\/))) (if (eqv? (string-ref (car parts) 0) #\~) -- cgit v1.2.3-54-g00ecf