aliens/tekuti
1
0
Fork 0
Code Activity

more cleanups, xhtml sanitization thanks to MikeS, --repl

Browse source
This commit is contained in:
Andy Wingo 2008-02-28 22:14:42 +01:00
parent 436ef22134
commit 0280eb9bd0
6 changed files with 82 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
tekuti/boot.scm
View file

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

77
tekuti/comment.scm
View file

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

32
tekuti/git.scm
View file

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

5
tekuti/mod-lisp.scm
View file

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

6
tekuti/page.scm
View file

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

13
tekuti/util.scm
View file

@ -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) #\~)