aliens/tekuti
1
0
Fork 0
Code Activity

modularization

Browse source
This commit is contained in:
Andy Wingo 2008-02-11 22:58:10 +01:00
parent 4c9b3b52ae
commit da58b95476
10 changed files with 787 additions and 428 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

462
src/tekuti
View file

@ -29,437 +29,43 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
;;; Code:
;;hack!
(use-modules (ice-9 regex))
(use-modules (ice-9 rdelim)
(ice-9 popen)
(srfi srfi-1)
(sxml simple)
(tekuti url)
(match-bind)
(sxml transform))
(debug-enable 'backtrace)
(define (expanduser path)
(let ((parts (string-split path #\/)))
(if (eqv? (string-ref (car parts) 0) #\~)
(let ((user (if (= (string-length (car parts)) 1)
(cuserid)
(substring (car parts) 1))))
(string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
path)))
(define *host* "127.0.0.1")
(define *port* 8081)
(define *backlog* 5)
(define *git-dir* (expanduser "~/blog.git"))
(define *git* "git")
(define *public-url-base* "/")
(define *private-url-base* "/blog/")
(define *debug* #t)
(define (dbg fmt . args)
(apply format (current-error-port) fmt args))
(define-macro (unwind-protect form . cleanups)
`(dynamic-wind (lambda () #t)
(lambda () ,form)
(lambda () ,@cleanups)))
(define-macro (with-pipe var make-pipe . body)
`(let ((,var ,make-pipe))
(unwind-protect
(begin ,@body)
(let ((ret (close-pipe ,var)))
(if (not (eq? (status:exit-val ret) 0))
(throw 'pipe-error ,var ret))))))
(define (git . args)
(with-pipe
pipe (apply open-pipe* OPEN_READ *git* "--bare" args)
(read-delimited "" pipe)))
;; true badness
(define (git/input+env input env . args)
(let* ((template (string-copy "/tmp/tekutiXXXXXX"))
(tmp (mkstemp! template)))
(display input tmp)
(close tmp)
(let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " ")))
(display cmd)(newline)
(unwind-protect
(with-pipe
pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
(string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " "))
(read-delimited "" pipe))
(delete-file template)))))
(define (is-dir? path)
(catch 'system-error
(lambda () (eq? (stat:type (stat path)) 'directory))
(lambda args #f)))
(define (ensure-git-repo)
(if (not (is-dir? *git-dir*))
(begin
(mkdir *git-dir*)
(chdir *git-dir*)
(git "init"))
(chdir *git-dir*)))
(define (strip-headers socket)
(define (read-line*)
(let ((line (read-line socket)))
(if (eof-object? line)
(error "unexpected eof")
line)))
(let lp ((keys '()) (values '()))
(let ((k (read-line*)))
(if (string=? k "end")
(reverse (map cons keys values))
(lp (cons k keys) (cons (read-line*) values))))))
(define (output-headers headers port)
(for-each
(lambda (k v)
(format port "~a\n~a\n" k v))
(map car headers) (map cdr headers))
(display "end\n" port))
(define-macro (let-headers headers bindings . body)
(let ((headers-var (gensym)))
`(let ((,headers-var ,headers))
(let (,@(map (lambda (binding)
`(,(car binding)
(or (assoc-ref ,headers-var ,(cadr binding))
(error "Missing header:" ,(cadr binding)))))
bindings))
,@body))))
(define (page-debug headers)
`(html (head (title "hello"))
(body (p "hello world!")
(table
(tr (th "header") (th "value"))
,@(map (lambda (pair)
`(tr (td ,(car pair)) (td ,(cdr pair))))
headers)))))
(define (visible-error . html-body)
(throw 'visible-error 404 html-body))
(define (page-not-found path)
(throw 'html-error 404 path))
(define (url-path-split path)
(filter (lambda (x) (not (string-null? x)))
(map url:decode (string-split path #\/))))
(define-macro (url-path-case method path . clauses)
(define (optional-argument arg)
(let ((len (string-length arg)))
(and (eqv? (string-ref arg (1- len)) #\?)
(substring arg 0 (1- len)))))
(let ((method-sym (gensym)) (path-parts (gensym)))
(define (process-clauses)
(map (lambda (clause)
(let ((pattern (car clause)) (body (cdr clause)))
(cond
((eq? pattern 'else)
clause)
(else
(let* ((method-match (car pattern))
(parts-match (map symbol->string (cdr pattern)))
(nargs (length parts-match))
(opt (or (find-tail optional-argument parts-match) '()))
(nopt (length opt))
(nreq (- nargs nopt)))
(cond
((null? opt)
`((and (eq? ,method-sym ',method-match)
(equal? ,path-parts ',parts-match))
,@body))
(else
`((and (eq? ,method-sym ',method-match)
(equal? (list-head ,path-parts ,nreq)
',(list-head parts-match nreq))
(< (length ,path-parts) ,nargs))
(apply
(lambda ,(map string->symbol (map optional-argument opt))
,@body)
(let ((tail (list-tail ,path-parts ,nreq)))
(append tail (make-list (- ,nopt (length tail)) #f))))))))))))
clauses))
`(let ((,method-sym (string->symbol ,method))
(,path-parts (url-path-split ,path)))
(cond ,@(process-clauses)))))
(define-macro (url-relative-path-case method path . clauses)
(let ((infix (map string->symbol (url-path-split *private-url-base*))))
(define (munge-clause clause)
(cond
((eq? (car clause) 'else) clause)
(else
(let ((method (caar clause))
(parts (cdar clause))
(body (cdr clause)))
`((,method ,@infix ,@parts) ,@body)))))
`(url-path-case ,method ,path
,@(map munge-clause clauses))))
(define (unimplemented . args)
(apply throw 'unimplemented args))
(use-modules (scheme session))
(use-modules (match-bind))
;;(putenv "GIT_DIR=/home/wingo/blog.git")
(define-macro (match-lines string pattern bindings expr)
(let ((line (gensym)) (seed (gensym)))
`(fold
(lambda (,line ,seed)
(match-bind ,pattern ,line ,bindings
(cons ,expr ,seed)
,seed))
'() (string-split ,string #\newline))))
(define (git-ls-tree treeish path)
(match-lines (git "ls-tree" treeish (or path "."))
"^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
(list mode type object name)))
(define (git-ls-subdirs treeish path)
(match-lines (git "ls-tree" treeish (or path "."))
"^(.+) tree (.+)\t(.+)$" (_ mode object name)
(cons name object)))
(define (dsu-sort list key less)
(map cdr
(stable-sort (map (lambda (x) (cons (key x) x)) list)
(lambda (x y) (less (car x) (car y))))))
(define (all-published-posts master)
(define (timestamp x)
(post-timestamp (cdr x)))
(dsu-sort
(filter timestamp (git-ls-subdirs master #f))
timestamp
<))
(define (post-metadata sha1)
(match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata"))
"^([^: ]+): +(.*)$" (_ k v)
(cons (string->symbol k) v)))
(define (post-timestamp sha1)
(and=> (assq-ref (post-metadata sha1) 'timestamp)
string->number))
(define (post-categories sha1)
(or (and=> (assq-ref (post-metadata sha1) 'categories)
(lambda (x) (map string-trim-both (string-split x #\,))))
'()))
(define (comment-metadata sha1)
(match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata"))
"^([^: ]+): +(.*)$" (_ k v)
(cons (string->symbol k) v)))
(define (comment-timestamp sha1)
(and=> (assq-ref (comment-metadata sha1) 'timestamp)
string->number))
(define (post-comments sha1)
(dsu-sort
(map cdr (git-ls-subdirs sha1 "comments/"))
comment-timestamp
<))
(define (parse-commit commit)
(let ((text (git "cat-file" "commit" commit)))
(match-bind
"\n\n(.*)$" text (_ message)
(acons
'message message
(match-lines (substring text 0 (- (string-length text) (string-length _)))
"^([^ ]+) (.*)$" (_ k v)
(cons (string->symbol k) v))))))
(define (commit-utc-timestamp commit)
(match-bind
"^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer)
(_ who ts tz)
(let ((ts (string->number ts)) (tz (string->number tz)))
(- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60)))))
(define (commit-parents commit)
(map cdr
(filter
(lambda (x) (eq? (car x) 'parent))
(parse-commit commit))))
(define (build-comment-skeleton comments)
(fold (lambda (sha1 parent)
(let* ((ts (comment-timestamp sha1))
(env (list "GIT_COMMMITTER=tekuti"
;; this quoting is a hack
(format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
(format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
(string-trim-both
(apply git/input+env "comment\n" env "commit-tree" sha1
(if parent (list "-p" parent) '())))))
#f
comments))
(define (build-post-skeleton master posts)
(fold (lambda (sha1 parent)
(let* ((ts (post-timestamp sha1))
(comments (build-comment-skeleton (post-comments sha1)))
(env (list "GIT_COMMMITTER=tekuti"
;; this quoting is a hack
(format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
(format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
(string-trim-both
(apply git/input+env "post\n" env "commit-tree" sha1
"-p" master
(append (if parent (list "-p" parent) '())
(if comments (list "-p" comments) '()))))))
#f
(map cdr posts)))
(define (reindex-posts master)
(build-post-skeleton master (all-published-posts master)))
(define (hash-push! h key value)
(let ((handle (hash-create-handle! h key '())))
(set-cdr! handle (cons value (cdr handle)))))
(define (make-tree alist)
(string-trim-both
(git/input+env (string-join
(map (lambda (pair)
(let ((name (car pair)) (sha (cdr pair)))
(format #f "040000 tree ~a\t~a" sha name)))
alist)
"\n" 'suffix)
'()
"mktree")))
(define (compute-categories posts)
(let ((hash (make-hash-table)))
(for-each
(lambda (post-pair)
(for-each
(lambda (cat)
(hash-push! hash cat post-pair))
(post-categories (cdr post-pair))))
posts)
hash))
(define (build-categories-tree master posts)
(if (null? posts)
#f
(let* ((hash (compute-categories posts))
(tree (make-tree (hash-map->list
(lambda (k v) (cons k (make-tree v)))
hash)))
(ts (commit-utc-timestamp master))
(env (list "GIT_COMMMITTER=tekuti"
;; this quoting is a hack
(format #f "'GIT_COMMITTER_DATE=~a +0000'" ts)
(format #f "'GIT_AUTHOR_DATE=~a +0000'" ts))))
(string-trim-both
(git/input+env "categories\n" env "commit-tree" tree
"-p" master))))) ;; FIXME: keep history?
(define (reindex-categories master)
(build-categories-tree master (all-published-posts master)))
(define (fetch-heads master)
(map (lambda (spec)
(let ((ref (car spec)) (reindex (cdr spec)))
(let ((head (false-if-exception
(string-trim-both (git "rev-parse" (car spec))))))
(cons
ref
(if (and head (member master (commit-parents head)))
head
(and=> (reindex master)
(lambda (new)
(if (not (false-if-exception
(if head
(git "update-ref" ref new head)
(git "branch" ref new))))
(dbg "couldn't update ref ~a to ~a" ref new))
new)))))))
`(("posts" . ,reindex-posts)
("categories" . ,reindex-categories))))
(use-modules (tekuti git)
(tekuti page)
(tekuti util)
(tekuti post)
(tekuti categories)
(tekuti mod-lisp)
(tekuti web))
(define (handle-request headers post-data)
(let-headers
headers ((method "method") (path "url"))
(url-relative-path-case
method path
((POST admin new-post)
(unimplemented 'new-post))
((POST admin modify-post)
(unimplemented 'modify-post))
((POST admin new-comment)
(unimplemented 'new-comment))
((POST admin delete-comment)
(unimplemented 'delete-comment))
((POST admin delete-post)
(unimplemented 'delete-post))
((GET)
(unimplemented 'index))
((GET archives year? month? day? post?)
(unimplemented 'archives))
((GET debug)
(page-debug headers))
((POST search)
(unimplemented 'search))
(else (page-not-found path)))))
(let ((heads (fetch-heads `(posts . ,reindex-posts)
`(categories . ,reindex-categories))))
(let-headers
headers ((method "method") (path "url"))
(url-relative-path-case
method path
((POST admin new-post)
(unimplemented 'new-post))
((POST admin modify-post)
(unimplemented 'modify-post))
((POST admin new-comment)
(unimplemented 'new-comment))
((POST admin delete-comment)
(unimplemented 'delete-comment))
((POST admin delete-post)
(unimplemented 'delete-post))
((GET)
(unimplemented 'index))
((GET archives year? month? day? post?)
(unimplemented 'archives))
((GET debug)
(page-debug headers))
((POST search)
(unimplemented 'search))
(else (page-not-found path))))))
(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 (connection-received socket sockaddr)
(let ((headers (strip-headers socket))
(post-data "")) ;; blocks: (read-delimited "" socket)))
(dbg "~a" headers)
(catch #t
(lambda ()
(let ((sxml (handle-request headers post-data)))
(output-headers '(("Status" . "200 OK")
("Content-Type" . "text/html"))
socket)
(display xhtml-doctype socket)
(sxml->xml sxml socket)))
(lambda args
(output-headers '(("Status" . "500 Internal Server Error")
("Content-Type" . "text/plain"))
socket)
(write args socket)))
(close-port socket)))
(define (event-loop socket)
(let ((master (string-trim-both (git "rev-parse" "master"))))
(pk (fetch-heads master)))
(pk 'listening)
(bind socket AF_INET (inet-aton *host*) *port*)
(listen socket *backlog*)
(let lp ((pair (accept socket)))
(pk pair)
(connection-received (car pair) (cdr pair))
(pk 'done)
(lp (accept socket))))
(define (main)
(define (main args)
(ensure-git-repo)
(event-loop (socket PF_INET SOCK_STREAM 0)))
(main)
(event-loop handle-request))

61
tekuti/categories.scm Normal file
View file

@ -0,0 +1,61 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti categories)
#:use-module (tekuti util)
#:use-module (tekuti post)
#:use-module (tekuti git)
#:export (reindex-categories))
(define (compute-categories posts)
(let ((hash (make-hash-table)))
(for-each
(lambda (post-pair)
(for-each
(lambda (cat)
(hash-push! hash cat post-pair))
(post-categories (cdr post-pair))))
posts)
hash))
(define (build-categories-tree master posts)
(if (null? posts)
#f
(let* ((hash (compute-categories posts))
(tree (make-tree (hash-map->list
(lambda (k v) (cons k (make-tree v)))
hash)))
(ts (commit-utc-timestamp master))
(env (list "GIT_COMMMITTER=tekuti"
;; this quoting is a hack
(format #f "'GIT_COMMITTER_DATE=~a +0000'" ts)
(format #f "'GIT_AUTHOR_DATE=~a +0000'" ts))))
(string-trim-both
(git/input+env "categories\n" env "commit-tree" tree
"-p" master))))) ;; FIXME: keep history?
(define (reindex-categories master)
(build-categories-tree master (all-published-posts master)))

65
tekuti/comment.scm Normal file
View file

@ -0,0 +1,65 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
;;hack!
(define-module (tekuti comment)
#:use-module (tekuti git)
#:use-module (tekuti util)
#:use-module (srfi srfi-1)
#:export (comment-from-tree build-comment-skeleton))
(use-modules (ice-9 regex))
(use-modules (ice-9 rdelim)
(ice-9 popen)
(srfi srfi-1)
(sxml simple)
(tekuti url)
(match-bind)
(sxml transform))
(debug-enable 'backtrace)
(define *comment-spec*
`((timestamp ,string->number)))
(define (comment-from-tree encoded-name sha1)
(acons 'encoded-name encoded-name
(parse-metadata (string-append sha1 ":" "metadata") *comment-spec*)))
(define (comment-timestamp comment-alist)
(or (assq-ref x 'timestamp) #f))
(define (build-comment-skeleton comments)
(fold (lambda (sha1 parent)
(let* ((ts (comment-timestamp sha1))
(env (list "GIT_COMMMITTER=tekuti"
;; this quoting is a hack
(format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
(format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
(string-trim-both
(git* (cons* "commit-tree" sha1 (if parent (list "-p" parent) '()))
#:input "comment\n" #:env env))))
#f
comments))

39
tekuti/config.scm Normal file
View file

@ -0,0 +1,39 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti config)
#:use-module (tekuti util)
#:export (*host* *port* *backlog* *git-dir* *git* *public-url-base*
*private-url-base* *debug*))
(define *host* "127.0.0.1")
(define *port* 8081)
(define *backlog* 5)
(define *git-dir* "~/blog.git")
(define *git* "git")
(define *public-url-base* "/")
(define *private-url-base* "/blog/")
(define *debug* #t)

172
tekuti/git.scm Normal file
View file

@ -0,0 +1,172 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti git)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 popen)
#:use-module (tekuti util)
#:use-module (tekuti config)
#:use-module (scheme kwargs)
#:use-module (match-bind)
#:use-module (ice-9 regex) ; hack
#:export (git git* ensure-git-repo git-ls-tree git-ls-subdirs
parse-metadata parse-commit commit-utc-timestamp
commit-parents make-tree fetch-heads))
(define (call-with-pipe pipe proc)
(unwind-protect
(proc pipe)
(let ((ret (close-pipe pipe)))
(if (not (eq? (status:exit-val ret) 0))
(throw 'pipe-error proc ret)))))
(define (call-with-temp-file contents proc)
(let* ((template (string-copy "/tmp/tekutiXXXXXX"))
(tmp (mkstemp! template)))
(display input tmp)
(close tmp)
(unwind-protect
(proc template)
(delete-file template))))
(define/kwargs (git* args (input #f) (env '()))
;; foolishness regarding env
(define (nyam-nyam-nyam pipe)
(read-delimited "" pipe))
(cond
(input
(call-with-temp-file
input
(lambda (tempname)
(let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,input) " ")))
(pk cmd)
(call-with-pipe
(open-pipe* OPEN_BOTH "/bin/sh" "-c" cmd)
nyam-nyam-nyam)))))
(else
(pk args)
(call-with-pipe
(apply open-pipe* OPEN_READ *git* "--bare" args)
nyam-nyam-nyam))))
(define (git . args)
(git* args))
(define (is-dir? path)
(catch 'system-error
(lambda () (eq? (stat:type (stat path)) 'directory))
(lambda args #f)))
(define (ensure-git-repo)
(let ((d (expanduser *git-dir*)))
(if (not (is-dir? d))
(begin
(mkdir d)
(chdir d)
(git "init"))
(chdir d))))
(define (git-ls-tree treeish path)
(match-lines (git "ls-tree" treeish (or path "."))
"^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
(list mode type object name)))
(define (git-ls-subdirs treeish path)
(match-lines (git "ls-tree" treeish (or path "."))
"^(.+) tree (.+)\t(.+)$" (_ mode object name)
(cons name object)))
(define (parse-metadata treeish . specs)
(filter
identity
(match-lines (git "cat-file" "blob" treeish)
"^([^: ]+): +(.*)$" (_ k v)
(let* ((k (string->symbol k))
(parse (assq-ref k specs)))
(if parse
(catch 'parse-error
(lambda ()
(cons k (parse v)))
(lambda args #f))
(cons k v))))))
(define (parse-commit commit)
(let ((text (git "cat-file" "commit" commit)))
(match-bind
"\n\n(.*)$" text (_ message)
(acons
'message message
(match-lines (substring text 0 (- (string-length text) (string-length _)))
"^([^ ]+) (.*)$" (_ k v)
(cons (string->symbol k) v))))))
(define (commit-utc-timestamp commit)
(match-bind
"^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer)
(_ who ts tz)
(let ((ts (string->number ts)) (tz (string->number tz)))
(- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60)))))
(define (commit-parents commit)
(map cdr
(filter
(lambda (x) (eq? (car x) 'parent))
(parse-commit commit))))
(define (make-tree alist)
(string-trim-both
(git* '("mktree")
#:input (string-join
(map (lambda (pair)
(let ((name (car pair)) (sha (cdr pair)))
(format #f "040000 tree ~a\t~a" sha name)))
alist)
"\n" 'suffix))))
(define (git-rev-parse rev)
(string-trim-both (git "rev-parse" rev)))
(define (fetch-heads . heads)
(let ((master (git-rev-parse "master")))
(acons
'master master
(map (lambda (spec)
(let ((ref (car spec)) (reindex (cdr spec)))
(let ((head (false-if-exception
(git-rev-parse (car spec)))))
(cons
ref
(if (and head (member master (commit-parents head)))
head
(and=> (reindex master)
(lambda (new)
(if (not (false-if-exception
(if head
(git "update-ref" ref new head)
(git "branch" ref new))))
(dbg "couldn't update ref ~a to ~a" ref new))
new)))))))
heads))))

93
tekuti/mod-lisp.scm Normal file
View file

@ -0,0 +1,93 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti mod-lisp)
#:use-module (ice-9 rdelim)
#:use-module (sxml simple)
#:use-module (sxml transform)
#:use-module (tekuti url)
#:use-module (tekuti util)
#:use-module (tekuti config)
#:export (event-loop))
(define (read-headers socket)
(define (read-line*)
(let ((line (read-line socket)))
(if (eof-object? line)
(error "unexpected eof")
line)))
(let lp ((keys '()) (values '()))
(let ((k (read-line*)))
(if (string=? k "end")
(reverse (map cons keys values))
(lp (cons k keys) (cons (read-line*) values))))))
(define (write-headers headers port)
(for-each
(lambda (k v)
(format port "~a\n~a\n" k v))
(map car headers) (map cdr headers))
(display "end\n" port))
(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 (connection-received socket sockaddr handle-request)
(let ((headers (read-headers socket))
(post-data "")) ;; blocks: (read-delimited "" socket)))
(dbg "~a" headers)
(catch #t
(lambda ()
(let ((sxml (handle-request headers post-data)))
(write-headers '(("Status" . "200 OK")
("Content-Type" . "text/html"))
socket)
(display xhtml-doctype socket)
(sxml->xml sxml socket)))
(lambda args
(write-headers '(("Status" . "500 Internal Server Error")
("Content-Type" . "text/plain"))
socket)
(write args socket)))
(close-port socket)))
(define (event-loop handle-request)
(pk 'listening)
(let ((socket (socket PF_INET SOCK_STREAM 0)))
(bind socket AF_INET (inet-aton *host*) *port*)
(listen socket *backlog*)
(unwind-protect
(let lp ((pair (accept socket)))
(pk pair)
(connection-received (car pair) (cdr pair) handle-request)
(pk 'done)
(lp (accept socket)))
(shutdown socket 2))))

37
tekuti/page.scm Normal file
View file

@ -0,0 +1,37 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti page)
#:export (page-debug))
(define (page-debug headers)
`(html (head (title "hello"))
(body (p "hello world!")
(table
(tr (th "header") (th "value"))
,@(map (lambda (pair)
`(tr (td ,(car pair)) (td ,(cdr pair))))
headers)))))

92
tekuti/post.scm Normal file
View file

@ -0,0 +1,92 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti post)
#:use-module (srfi srfi-1)
#:use-module (match-bind)
#:use-module (tekuti util)
#:use-module (tekuti comment)
#:use-module (tekuti git)
#:use-module (srfi srfi-1)
#:export (reindex-posts post-categories all-published-posts))
;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
;; perhaps push this processing into post-from-tree
(define (post-published? post-alist)
(equal? (assq-ref post-alist 'status) "published"))
(define (post-timestamp post-alist)
(or (assq-ref x 'timestamp) #f))
(define (post-categories post-alist)
(or (assq-ref x 'categories) '()))
(define *post-spec*
`((timestamp ,string->number)
(categories ,(lambda (v) (map string-trim-both (string-split v #\,))))))
(define (post-from-tree encoded-name sha1)
(acons 'url encoded-name
(parse-metadata (string-append sha1 ":" "metadata") *post-spec*)))
(define (all-posts master)
(map (lambda (pair)
(post-from-tree (car pair) (cdr pair)))
(git-ls-subdirs master #f)))
(define (all-published-posts master)
(dsu-sort
(filter post-published? (all-posts master))
post-timestamp
<))
(define (post-comments sha1)
(dsu-sort
(map (lambda (pair)
(comment-from-tree (car pair) (cdr pair)))
(git-ls-subdirs sha1 "comments/"))
comment-timestamp
<))
(define (build-post-skeleton master posts)
(fold (lambda (sha1 parent)
(let* ((ts (post-timestamp sha1))
(comments (build-comment-skeleton (post-comments sha1)))
(env (list "GIT_COMMMITTER=tekuti"
;; this quoting is a hack
(format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
(format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
(string-trim-both
(git* `("commit-tree" ,sha1
,@(if parent (list "-p" parent) '())
,@(if comments (list "-p" comments) '()))
#:input "post\n" #:env env))))
#f
(map cdr posts)))
(define (reindex-posts master)
(build-post-skeleton master (all-published-posts master)))

65
tekuti/util.scm Normal file
View file

@ -0,0 +1,65 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti util)
#:use-module (match-bind)
#:use-module (srfi srfi-1)
#:export (expanduser match-lines dbg unwind-protect dbg dsu-sort hash-push!))
(define (expanduser path)
(let ((parts (string-split path #\/)))
(if (eqv? (string-ref (car parts) 0) #\~)
(let ((user (if (= (string-length (car parts)) 1)
(cuserid)
(substring (car parts) 1))))
(string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
path)))
(define-macro (match-lines string pattern bindings expr)
(let ((line (gensym)) (seed (gensym)))
`(,fold
(lambda (,line ,seed)
(match-bind ,pattern ,line ,bindings
(cons ,expr ,seed)
,seed))
'() (string-split ,string #\newline))))
(define (dbg fmt . args)
(apply format (current-error-port) fmt args))
(define-macro (unwind-protect form . cleanups)
`(dynamic-wind (lambda () #t)
(lambda () ,form)
(lambda () ,@cleanups)))
(define (dsu-sort list key less)
(map cdr
(stable-sort (map (lambda (x) (cons (key x) x)) list)
(lambda (x y) (less (car x) (car y))))))
(define (hash-push! h key value)
(let ((handle (hash-create-handle! h key '())))
(set-cdr! handle (cons value (cdr handle)))))

129
tekuti/web.scm Normal file
View file

@ -0,0 +1,129 @@
;; Tekuti
;; Copyright (C) 2008 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:
;;
;; This is the main script that will launch tekuti.
;;
;;; Code:
(define-module (tekuti web)
#:use-module (sxml simple)
#:use-module (sxml transform)
#:use-module (tekuti url)
#:use-module (tekuti config)
#:use-module (srfi srfi-1)
#:export (read-headers write-headers let-headers
visible-error page-not-found unimplemented
url-path-split url-path-case url-relative-path-case))
(define (read-headers socket)
(define (read-line*)
(let ((line (read-line socket)))
(if (eof-object? line)
(error "unexpected eof")
line)))
(let lp ((keys '()) (values '()))
(let ((k (read-line*)))
(if (string=? k "end")
(reverse (map cons keys values))
(lp (cons k keys) (cons (read-line*) values))))))
(define (write-headers-headers headers port)
(for-each
(lambda (k v)
(format port "~a\n~a\n" k v))
(map car headers) (map cdr headers))
(display "end\n" port))
(define-macro (let-headers headers bindings . body)
(let ((headers-var (gensym)))
`(let ((,headers-var ,headers))
(let (,@(map (lambda (binding)
`(,(car binding)
(or (assoc-ref ,headers-var ,(cadr binding))
(error "Missing header:" ,(cadr binding)))))
bindings))
,@body))))
(define (visible-error . html-body)
(throw 'visible-error 404 html-body))
(define (page-not-found path)
(throw 'html-error 404 path))
(define (url-path-split path)
(filter (lambda (x) (not (string-null? x)))
(map url:decode (string-split path #\/))))
(define-macro (url-path-case method path . clauses)
(define (optional-argument arg)
(let ((len (string-length arg)))
(and (eqv? (string-ref arg (1- len)) #\?)
(substring arg 0 (1- len)))))
(let ((method-sym (gensym)) (path-parts (gensym)))
(define (process-clauses)
(map (lambda (clause)
(let ((pattern (car clause)) (body (cdr clause)))
(cond
((eq? pattern 'else)
clause)
(else
(let* ((method-match (car pattern))
(parts-match (map symbol->string (cdr pattern)))
(nargs (length parts-match))
(opt (or (find-tail optional-argument parts-match) '()))
(nopt (length opt))
(nreq (- nargs nopt)))
(cond
((null? opt)
`((and (eq? ,method-sym ',method-match)
(equal? ,path-parts ',parts-match))
,@body))
(else
`((and (eq? ,method-sym ',method-match)
(equal? (list-head ,path-parts ,nreq)
',(list-head parts-match nreq))
(< (length ,path-parts) ,nargs))
(apply
(lambda ,(map string->symbol (map optional-argument opt))
,@body)
(let ((tail (list-tail ,path-parts ,nreq)))
(append tail (make-list (- ,nopt (length tail)) #f))))))))))))
clauses))
`(let ((,method-sym (string->symbol ,method))
(,path-parts (url-path-split ,path)))
(cond ,@(process-clauses)))))
(define-macro (url-relative-path-case method path . clauses)
(let ((infix (map string->symbol (url-path-split *private-url-base*))))
(define (munge-clause clause)
(cond
((eq? (car clause) 'else) clause)
(else
(let ((method (caar clause))
(parts (cdar clause))
(body (cdr clause)))
`((,method ,@infix ,@parts) ,@body)))))
`(url-path-case ,method ,path
,@(map munge-clause clauses))))
(define (unimplemented . args)
(apply throw 'unimplemented args))