aliens/tekuti
1
0
Fork 0
Code Activity

further hacking

Browse source
This commit is contained in:
Andy Wingo 2008-02-09 21:37:57 +01:00
parent 2cae173de9
commit 04ee329b4b
4 changed files with 672 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
env Executable file
View file

@ -0,0 +1,8 @@
#!/bin/sh
this_dir=$(cd $(dirname $0) && pwd)
GUILE_LOAD_PATH=$this_dir/$pkg:$GUILE_LOAD_PATH
export GUILE_LOAD_PATH
exec "$@"

297
src/tekuti
View file

@ -1,6 +1,6 @@
#! /bin/bash
# -*- scheme -*-
exec guile $GUILE_FLAGS -s $0 "$@"
exec guile $GUILE_FLAGS -l $0 -e main "$@"
!#
;; Tekuti
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
@ -29,20 +29,80 @@ exec guile $GUILE_FLAGS -s $0 "$@"
;;; Code:
(use-modules (ice-9 rdelim))
(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 *socket* (socket PF_INET SOCK_STREAM 0))
(bind *socket* AF_INET (inet-aton *host*) *port*)
(listen *socket* *backlog*)
(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 'system-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 input . args)
(let* ((template "/tmp/tekutiXXXXXX")
(tmp (mkstemp! template)))
(display input tmp)
(close tmp)
(unwind-protect
(with-pipe
pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
(string-join `(,*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)))
@ -55,33 +115,232 @@ exec guile $GUILE_FLAGS -s $0 "$@"
(reverse (map cons keys values))
(lp (cons k keys) (cons (read-line*) values))))))
(define (output-headers headers)
(define (output-headers headers port)
(for-each
(lambda (k v)
(format #t "~a\n~a\n" k v))
(format port "~a\n~a\n" k v))
(map car headers) (map cdr headers))
(display "end\n"))
(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)
(dsu-sort
(filter post-timestamp (map cdr (git-ls-subdirs "master" #f)))
post-timestamp
<))
(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 (build-comment-skeleton comments)
(fold (lambda (sha1 parent)
(string-trim-both
(if parent
(git/input "comment" "commit-tree" sha1)
(git/input "comment" "commit-tree" "-p" parent sha1))))
#f
comments))
(post-comments "085138c227a15c1462138958868f8ef45741e5c5")
(git/input "comment" "commit-tree" "fae8f17277f74fe1e0710fd3be6ebb7879b65969")
(all-published-posts)
(string-trim-both "aadabe54f0a4d141657f208645955a2c85af4e0b
")
(post-metadata "9a83feef2c2304797ad295043d1f33d8e2dae52d")
(define (reindex-posts)
(define (reindex)
(reindex-posts)
(reindex-categories))
(define (handle-request headers post-data)
(output-headers '(("Status" . "200 OK")
("Content-Type" . "text/html")))
(display "<html><head><title>hello</title><body><p>hello world</p></body>"))
(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)
(with-output-to-port socket
(lambda ()
(handle-request headers post-data)))
(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)
(define (event-loop socket)
(pk 'listening)
(let ((pair (accept *socket*)))
(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)
(event-loop)))
(lp (accept socket))))
(event-loop)
(define (main)
(ensure-git-repo)
(event-loop (socket PF_INET SOCK_STREAM 0)))
(main)

215
tekuti/popen.scm Normal file
View file

@ -0,0 +1,215 @@
;; popen emulation, for non-stdio based ports.
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (tekuti popen)
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe))
(define (make-rw-port read-port write-port)
(make-soft-port
(vector
(lambda (c) (write-char c write-port))
(lambda (s) (display s write-port))
(lambda () (force-output write-port))
(lambda () (read-char read-port))
(lambda () (close-port read-port) (close-port write-port)))
"r+"))
;; a guardian to ensure the cleanup is done correctly when
;; an open pipe is gc'd or a close-port is used.
(define pipe-guardian (make-guardian))
;; a weak hash-table to store the process ids.
(define port/pid-table (make-weak-key-hash-table 31))
(define (ensure-fdes port mode)
(or (false-if-exception (fileno port))
(open-fdes *null-device* mode)))
;; run a process connected to an input, an output or an
;; input/output port
;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
;; returns port/pid pair.
(define (open-process mode prog . args)
(let* ((reading (or (equal? mode OPEN_READ)
(equal? mode OPEN_BOTH)))
(writing (or (equal? mode OPEN_WRITE)
(equal? mode OPEN_BOTH)))
(c2p (if reading (pipe) #f)) ; child to parent
(p2c (if writing (pipe) #f))) ; parent to child
(if c2p (setvbuf (cdr c2p) _IONBF))
(if p2c (setvbuf (cdr p2c) _IONBF))
(let ((pid (primitive-fork)))
(cond ((= pid 0)
;; child
(set-batch-mode?! #t)
;; select the three file descriptors to be used as
;; standard descriptors 0, 1, 2 for the new
;; process. They are pipes to/from the parent or taken
;; from the current Scheme input/output/error ports if
;; possible.
(let ((input-fdes (if writing
(fileno (car p2c))
(ensure-fdes (current-input-port)
O_RDONLY)))
(output-fdes (if reading
(fileno (cdr c2p))
(ensure-fdes (current-output-port)
O_WRONLY)))
(error-fdes (ensure-fdes (current-error-port)
O_WRONLY)))
;; close all file descriptors in ports inherited from
;; the parent except for the three selected above.
;; this is to avoid causing problems for other pipes in
;; the parent.
;; use low-level system calls, not close-port or the
;; scsh routines, to avoid side-effects such as
;; flushing port buffers or evicting ports.
(port-for-each (lambda (pt-entry)
(false-if-exception
(let ((pt-fileno (fileno pt-entry)))
(if (not (or (= pt-fileno input-fdes)
(= pt-fileno output-fdes)
(= pt-fileno error-fdes)))
(close-fdes pt-fileno))))))
;; Copy the three selected descriptors to the standard
;; descriptors 0, 1, 2, if not already there
(cond ((not (= input-fdes 0))
(if (= output-fdes 0)
(set! output-fdes (dup->fdes 0)))
(if (= error-fdes 0)
(set! error-fdes (dup->fdes 0)))
(dup2 input-fdes 0)
;; it's possible input-fdes is error-fdes
(if (not (= input-fdes error-fdes))
(close-fdes input-fdes))))
(cond ((not (= output-fdes 1))
(if (= error-fdes 1)
(set! error-fdes (dup->fdes 1)))
(dup2 output-fdes 1)
;; it's possible output-fdes is error-fdes
(if (not (= output-fdes error-fdes))
(close-fdes output-fdes))))
(cond ((not (= error-fdes 2))
(dup2 error-fdes 2)
(close-fdes error-fdes)))
(apply execlp prog prog args)))
(else
;; parent
(if c2p (close-port (cdr c2p)))
(if p2c (close-port (car p2c)))
(cons (cond ((not writing) (car c2p))
((not reading) (cdr p2c))
(else (make-rw-port (car c2p)
(cdr p2c))))
pid))))))
(define (open-pipe* mode command . args)
"Executes the program @var{command} with optional arguments
@var{args} (all strings) in a subprocess.
A port to the process (based on pipes) is created and returned.
@var{modes} specifies whether an input, an output or an input-output
port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
(let* ((port/pid (apply open-process mode command args))
(port (car port/pid)))
(pipe-guardian port)
(hashq-set! port/pid-table port (cdr port/pid))
port))
(define (open-pipe command mode)
"Executes the shell command @var{command} (a string) in a subprocess.
A port to the process (based on pipes) is created and returned.
@var{modes} specifies whether an input, an output or an input-output
port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
(open-pipe* mode "/bin/sh" "-c" command))
(define (fetch-pid port)
(let ((pid (hashq-ref port/pid-table port)))
(hashq-remove! port/pid-table port)
pid))
(define (close-process port/pid)
(close-port (car port/pid))
(cdr (waitpid (cdr port/pid))))
;; for the background cleanup handler: just clean up without reporting
;; errors. also avoids blocking the process: if the child isn't ready
;; to be collected, puts it back into the guardian's live list so it
;; can be tried again the next time the cleanup runs.
(define (close-process-quietly port/pid)
(catch 'system-error
(lambda ()
(close-port (car port/pid)))
(lambda args #f))
(catch 'system-error
(lambda ()
(let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
(cond ((= (car pid/status) 0)
;; not ready for collection
(pipe-guardian (car port/pid))
(hashq-set! port/pid-table
(car port/pid) (cdr port/pid))))))
(lambda args #f)))
(define (close-pipe p)
"Closes the pipe created by @code{open-pipe}, then waits for the process
to terminate and returns its status value, @xref{Processes, waitpid}, for
information on how to interpret this value."
(let ((pid (fetch-pid p)))
(if (not pid)
(error "close-pipe: pipe not in table"))
(close-process (cons p pid))))
(define reap-pipes
(lambda ()
(let loop ((p (pipe-guardian)))
(cond (p
;; maybe removed already by close-pipe.
(let ((pid (fetch-pid p)))
(if pid
(close-process-quietly (cons p pid))))
(loop (pipe-guardian)))))))
(add-hook! after-gc-hook reap-pipes)
(define (open-input-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
(open-pipe command OPEN_READ))
(define (open-output-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
(open-pipe command OPEN_WRITE))
(define (open-input-output-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
(open-pipe command OPEN_BOTH))

171
tekuti/url.scm Normal file
View file

@ -0,0 +1,171 @@
;;; www/url.scm --- URL manipulation tools
;; Copyright (C) 1997,2001,2002 Free Software Foundation, Inc.
;;
;; 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 2, 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 software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;
;;; Commentary:
;; This module exports the following procedures:
;; (url:scheme url)
;; (url:address url)
;; (url:unknown url)
;; (url:user url)
;; (url:host url)
;; (url:port url)
;; (url:path url)
;; (url:make scheme . args)
;; (url:make-http host port path)
;; (url:make-ftp user host port path)
;; (url:make-mailto address)
;; (url:parse url)
;; (url:unparse url)
;; (url:decode str)
;; (url:encode str reserved-chars)
;;; Code:
;; TODO:
;; * support `user:password@' strings where appropriate in URLs.
;; * make URL parsing smarter. This is good for most TCP/IP-based
;; URL schemes, but parsing is actually specific to each URL scheme.
;; * fill out url:encode, include facilities for URL-scheme-specific
;; encoding methods (e.g. a url-scheme-reserved-char-alist)
(define-module (tekuti url)
#:use-module (ice-9 regex))
;; `url:scheme' is an unfortunate term, but it is the technical
;; name for that portion of the URL according to RFC 1738. Sigh.
(define-public (url:scheme url) (vector-ref url 0))
(define-public (url:address url) (vector-ref url 1))
(define-public (url:unknown url) (vector-ref url 1))
(define-public (url:user url) (vector-ref url 1))
(define-public (url:host url) (vector-ref url 2))
(define-public (url:port url) (vector-ref url 3))
(define-public (url:path url) (vector-ref url 4))
(define-public (url:make scheme . args)
(apply vector scheme args))
(define-public (url:make-http host port path)
(vector 'http #f host port path))
(define-public (url:make-ftp user host port path)
(vector 'ftp user host port path))
(define-public (url:make-mailto address)
(vector 'mailto address))
(define http-regexp (make-regexp "^http://([^:/]+)(:([0-9]+))?(/(.*))?$"))
(define ftp-regexp
(make-regexp "^ftp://(([^@:/]+)@)?([^:/]+)(:([0-9]+))?(/(.*))?$"))
(define mailto-regexp (make-regexp "^mailto:(.*)$"))
(define-public (url:parse url)
(cond
((regexp-exec http-regexp url)
=> (lambda (m)
(url:make-http (match:substring m 1)
(cond ((match:substring m 3) => string->number)
(else #f))
(match:substring m 5))))
((regexp-exec ftp-regexp url)
=> (lambda (m)
(url:make-ftp (match:substring m 2)
(match:substring m 3)
(cond ((match:substring m 5) => string->number)
(else #f))
(match:substring m 7))))
((regexp-exec mailto-regexp url)
=> (lambda (m)
(url:make-mailto (match:substring m 1))))
(else
(url:make 'unknown url))))
(define-public (url:unparse url)
(define (pathy scheme username url) ; username not used!
(format #f "~A://~A~A~A"
scheme
(url:host url)
(cond ((url:port url) => (lambda (port) (format #f ":~A" port)))
(else ""))
(cond ((url:path url) => (lambda (path) (format #f "/~A" path)))
(else ""))))
(case (url:scheme url)
((http) (pathy 'http #f url))
((ftp) (pathy 'ftp (url:user url) url))
((mailto) (format #f "mailto:~A" (url:address url)))
((unknown) (url:unknown url))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (url-decode STR)
;; Turn + into space, and hex-encoded %XX strings into their
;; eight-bit characters. Is a regexp faster than character
;; scanning? Does it incur more overhead (which may be more
;; important for code that frequently gets restarted)?
(define-public (url:decode str)
(regexp-substitute/global
#f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str
'pre
(lambda (m)
(cond ((string=? "+" (match:substring m 0)) " ")
(else (integer->char
(string->number
(match:substring m 1)
16)))))
'post))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (url-encode STR)
;; The inverse of url-decode. Can't be done easily with
;; a regexp: we would have to construct a regular expression
;; like "[\277-\377]", for example, and Guile strings don't
;; let you interpolate character literals. Pity.
;; URL-encode any characters in STR that are not safe: these
;; include any character not in the SAFE-CHARS list and any
;; character that *is* in the RESERVED-CHARS list argument.
(define-public (url:encode str reserved-chars)
(with-output-to-string
(lambda ()
(for-each (lambda (ch)
(if (and (safe-char? ch)
(not (memv ch reserved-chars)))
(display ch)
(begin
(display #\%)
(display (number->string (char->integer ch) 16)))))
(string->list str)))))
(define safe-chars
'(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\, #\; #\/ #\? #\: #\@ #\& #\=))
(define (safe-char? ch)
;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and
;; reserved characters used for their reserved purposes may be used
;; unencoded within a URL.'' RFC 1738, #2.2.
(or (char-alphabetic? ch)
(char-numeric? ch)
(memv ch safe-chars)))
;;; www/url.scm ends here