diff options
| -rw-r--r-- | tekuti/git.scm | 8 | ||||
| -rw-r--r-- | tekuti/request.scm | 112 | ||||
| -rw-r--r-- | tekuti/util.scm | 61 | ||||
| -rw-r--r-- | tekuti/web.scm | 13 |
4 files changed, 93 insertions, 101 deletions
diff --git a/tekuti/git.scm b/tekuti/git.scm index e8793a4..118a09c 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -56,9 +56,11 @@ (output git-condition-output) (status git-condition-status)) -(define-macro (false-if-git-error . body) - `(,guard (c ((,git-condition? c) #f)) - ,@body)) +(define-syntax false-if-git-error + (syntax-rules () + ((_ body0 body ...) + (guard (c ((git-condition? c) #f)) + body0 body ...)))) ;;; ;;; running git diff --git a/tekuti/request.scm b/tekuti/request.scm index 08b9adf..d10895e 100644 --- a/tekuti/request.scm +++ b/tekuti/request.scm @@ -128,68 +128,80 @@ #f) #f))))) -(define-macro (let-request request bindings . body) - (let ((request-var (gensym))) +(define-syntax let-request + (lambda (stx) (define (make-binding b) - (cond - ((symbol? b) `(,b (,rref ,request-var ',b))) - ((list? b) `(,(car b) (,rref ,request-var ',(car b) ,@(cdr b)))) - (else (error "what" b)))) - `(let ((,request-var ,request)) - (let (,@(map make-binding bindings)) - ,@body)))) - -(define-macro (path-proc-case path . clauses) - (let ((path-var (gensym))) + (syntax-case b () + ((id option ...) + (identifier? #'id) + #'(id (rref request-var 'id option ...))) + (id + (identifier? #'id) + #'(id (rref request-var 'id))))) + (syntax-case stx () + ((_ request (binding ...) body ...) + (with-syntax (((binding ...) (map make-binding #'(binding ...)))) + #`(let ((request-var request)) + (let (binding ...) + body ...))))))) + +(define-syntax path-proc-case + (lambda (stx) (define (optional-argument? arg) - (eqv? (string-ref arg (1- (string-length arg))) #\?)) + (eqv? (string-ref arg (- (string-length arg) 1)) #\?)) (define (required-argument? arg) - (eqv? (string-ref arg (1- (string-length arg))) #\!)) + (eqv? (string-ref arg (- (string-length arg) 1)) #\!)) (define (output-argument? arg) (or (optional-argument? arg) (required-argument? arg))) (define (process-clause clause) - (or (list-has-length? clause 2) (error "foo")) - (if (eq? (car clause) 'else) - clause - (let ((pat (map symbol->string (car clause))) - (proc (cadr clause))) - (cond - ((find-tail output-argument? pat) - => (lambda (tail) - (define test - (let* ((npat (length pat)) - (ntail (length tail)) - (req (find-tail required-argument? tail)) - (opt (find-tail optional-argument? tail)) - (nopt (if opt (length opt) 0)) - (nreq (if req (- (length req) nopt) 0))) - (lambda (path) - (let ((pathtail (list-head-match pat path (- npat ntail)))) - ;(pk pat npat ntail req opt nopt nreq path pathtail) - (if (and pathtail (>= (length pathtail) nreq) - (<= (length pathtail) (+ nreq nopt))) - (append pathtail - (make-list (- (+ nreq nopt) (length pathtail)) #f)) - #f))))) - `((,test ,path-var) - => (lambda (outargs) - (lambda args - (apply ,proc (append args outargs))))))) - (else - `((equal? ,path-var ',pat) ,proc)))))) - `(let ((,path-var ,path)) - (cond ,@(map process-clause clauses))))) + (syntax-case clause (else) + ((else expr ...) clause) + (((p ...) proc) + (let ((pat (map (lambda (p) + (symbol->string (syntax->datum p))) + #'(p ...)))) + (cond + ((find-tail output-argument? pat) + => (lambda (tail) + (let* ((req (find-tail required-argument? tail)) + (opt (find-tail optional-argument? tail)) + (npat (length pat)) + (ntail (length tail)) + (nopt (if opt (length opt) 0)) + (nreq (if req (- (length req) nopt) 0))) + #`((let ((pathtail (list-head-match '#,pat + path-var + (- #,npat #,ntail)))) + ;;(pk pat npat ntail req opt nopt nreq path pathtail) + (if (and pathtail (>= (length pathtail) #,nreq) + (<= (length pathtail) (+ #,nreq #,nopt))) + (append + pathtail + (make-list (- (+ #,nreq #,nopt) (length pathtail)) #f)) + #f)) + => (lambda (outargs) + (lambda args + (apply proc (append args outargs)))))))) + (else + #`((equal? path-var '#,pat) proc))))))) + (syntax-case stx () + ((_ path clause ...) + (with-syntax (((cond-clause ...) (map process-clause #'(clause ...)))) + #`(let ((path-var path)) + (cond cond-clause ...))))))) (define (rcons*-fold request . keys-and-procs) (foldn (lambda (request k proc) (rcons k (proc request) request)) 2 request keys-and-procs)) -(define-macro (request-path-case request . clauses) - `(,path-proc-case - (,let-request ,request (method path) - (cons method path)) - ,@clauses)) +(define-syntax request-path-case + (syntax-rules () + ((_ request clause ...) + (path-proc-case + (let-request request (method path) + (cons method path)) + clause ...)))) (define (request-server-name request) (let ((headers (rref request 'headers))) diff --git a/tekuti/util.scm b/tekuti/util.scm index 7d4efdf..92e1853 100644 --- a/tekuti/util.scm +++ b/tekuti/util.scm @@ -36,7 +36,7 @@ date-increment date-comparator date-before? date-after? compose1 rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date timestamp->date string-split/trimming - list-intersperse with-backtrace with-time-debugging define-memoized)) + list-intersperse with-backtrace with-time-debugging)) (define (emailish? x) (match-bind "^([a-zA-Z0-9._+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$" @@ -88,36 +88,26 @@ (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)))) - -;; clause := ((pat args) body...) -(define-macro (match-case string . clauses) - (let ((str (gensym))) - `(let ((,str ,string)) - ,(let lp ((in clauses)) - (let ((clause (car in))) - (if (eq? (car clause) 'else) - `(begin ,@(cdr clause)) - `(match-bind ,(caar clause) ,str ,(cadar clause) - (begin ,@(cdr clause)) - ,(if (null? (cdr in)) - #f - (lp (cdr in)))))))))) +(define-syntax match-lines + (syntax-rules () + ((_ string pattern bindings expr) + (let ((rx (irregex pattern))) + (fold + (lambda (line seed) + (match-bind rx 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-syntax unwind-protect + (syntax-rules () + ((_ form cleanup0 cleanups ...) + (dynamic-wind (lambda () #t) + (lambda () form) + (lambda () cleanup0 cleanups ...))))) (define (dsu-sort list key less) (map cdr @@ -196,8 +186,10 @@ (fluid-set! the-last-stack (make-stack #t 2 0)) (apply throw args))))) -(define-macro (with-backtrace . forms) - `(,with-backtrace* (lambda () ,@forms))) +(define-syntax with-backtrace + (syntax-rules () + ((_ form0 forms ...) + (with-backtrace* (lambda () form0 forms ...))))) (define (gettimeofday-diff prev) (let ((now (gettimeofday))) @@ -211,8 +203,10 @@ (proc) (pk 'stop-clock (gettimeofday-diff start))))) -(define-macro (with-time-debugging . forms) - `(,with-time-debugging* (lambda () ,@forms))) +(define-syntax with-time-debugging + (syntax-rules () + ((_ form0 forms ...) + (with-time-debugging* (lambda () form0 forms ...))))) (define (memoize1 proc) (let ((old-args #f) (cache #f) (proc proc)) @@ -224,11 +218,6 @@ (set! cache val) val))))) -(define-macro (define-memoized form . body) - `(begin - (define ,form ,@body) - (set! ,(car form) (,memoize1 ,(car form))))) - (define (write-hash h) (write (hash-fold acons '() h))) diff --git a/tekuti/web.scm b/tekuti/web.scm index 6be887f..437ffd8 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -32,7 +32,7 @@ #:use-module (tekuti template) #:use-module (tekuti page) #:use-module (srfi srfi-1) - #:export (let-headers header-ref + #:export (header-ref handle-request)) (define *status-names* @@ -53,17 +53,6 @@ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")) -;;; useless macro -(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 (make-output request) (lambda (port) (let ((sxml (or (rref request 'sxml #f) |