From da58b954769ecfda8c167fe4644d26ce7e974f0b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Feb 2008 22:58:10 +0100 Subject: modularization --- src/tekuti | 462 ++++---------------------------------------------- tekuti/categories.scm | 61 +++++++ tekuti/comment.scm | 65 +++++++ tekuti/config.scm | 39 +++++ tekuti/git.scm | 172 +++++++++++++++++++ tekuti/mod-lisp.scm | 93 ++++++++++ tekuti/page.scm | 37 ++++ tekuti/post.scm | 92 ++++++++++ tekuti/util.scm | 65 +++++++ tekuti/web.scm | 129 ++++++++++++++ 10 files changed, 787 insertions(+), 428 deletions(-) create mode 100644 tekuti/categories.scm create mode 100644 tekuti/comment.scm create mode 100644 tekuti/config.scm create mode 100644 tekuti/git.scm create mode 100644 tekuti/mod-lisp.scm create mode 100644 tekuti/page.scm create mode 100644 tekuti/post.scm create mode 100644 tekuti/util.scm create mode 100644 tekuti/web.scm diff --git a/src/tekuti b/src/tekuti index c68b12d..c3dccfa 100755 --- a/src/tekuti +++ b/src/tekuti @@ -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 - "\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)) diff --git a/tekuti/categories.scm b/tekuti/categories.scm new file mode 100644 index 0000000..fd97d76 --- /dev/null +++ b/tekuti/categories.scm @@ -0,0 +1,61 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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))) diff --git a/tekuti/comment.scm b/tekuti/comment.scm new file mode 100644 index 0000000..91f7ffe --- /dev/null +++ b/tekuti/comment.scm @@ -0,0 +1,65 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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)) diff --git a/tekuti/config.scm b/tekuti/config.scm new file mode 100644 index 0000000..589eb37 --- /dev/null +++ b/tekuti/config.scm @@ -0,0 +1,39 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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) diff --git a/tekuti/git.scm b/tekuti/git.scm new file mode 100644 index 0000000..0ebf26c --- /dev/null +++ b/tekuti/git.scm @@ -0,0 +1,172 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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)))) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm new file mode 100644 index 0000000..613bda9 --- /dev/null +++ b/tekuti/mod-lisp.scm @@ -0,0 +1,93 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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 + "\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)))) + diff --git a/tekuti/page.scm b/tekuti/page.scm new file mode 100644 index 0000000..06ff37a --- /dev/null +++ b/tekuti/page.scm @@ -0,0 +1,37 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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))))) diff --git a/tekuti/post.scm b/tekuti/post.scm new file mode 100644 index 0000000..77dcf11 --- /dev/null +++ b/tekuti/post.scm @@ -0,0 +1,92 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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))) diff --git a/tekuti/util.scm b/tekuti/util.scm new file mode 100644 index 0000000..2019f55 --- /dev/null +++ b/tekuti/util.scm @@ -0,0 +1,65 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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))))) diff --git a/tekuti/web.scm b/tekuti/web.scm new file mode 100644 index 0000000..f84ad2a --- /dev/null +++ b/tekuti/web.scm @@ -0,0 +1,129 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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)) -- cgit v1.2.3-54-g00ecf