#lang scheme/base
(require (file "util.scm")
(lib "xml.ss" "xml")
(lib "url.ss" "net")
(planet "web.scm" ("soegaard" "web.plt" 2 1))
)
(provide request-all-bindings
remove-group-tags
xexpr->de-grouped-xexprs
wrap-each-in-list
wrap-each-in-list-with-attrs
redirect-to
web-link
raw-str
with-binding list-response
)
(define (list-response content-lst #:type (type #"text/html") #:extras (extras '()))
(make-response/full 200 "all good" (current-seconds) type extras
(append-map (lambda (content)
(map xexpr->string (xexpr->de-grouped-xexprs content)))
content-lst)))
(define (request-all-bindings req)
(append (request-bindings req)
(if (request-post-data/raw req) (url-query (request-uri req))
'())))
(define (group-tag? xexpr)
(match xexpr ((list-rest 'group children) #t) (else #f)))
(define (remove-group-tags xexpr)
(let ((result (xexpr->de-grouped-xexprs xexpr)))
(if (length= result 1)
(first result)
(e "Cannot remove-group-tags because I found ~A exprs in ~A. Expected just one."
(length result) result))))
(define (xexpr->de-grouped-xexprs xexpr)
(cond ((not xexpr) '())
((not (list? xexpr)) (list xexpr))
((group-tag? xexpr) (append-map xexpr->de-grouped-xexprs (rest xexpr)))
(else (receive (tag attrs children) (xexpr->tag*attrs*children xexpr)
(list (create-xexpr tag attrs
(append-map xexpr->de-grouped-xexprs children)))))))
(define (attrs? thing)
(and (list? thing)
(or (empty? thing) (not (symbol? (first thing))))))
(define (create-xexpr tag attrs children)
(if (empty? attrs)
`(,tag ,@children)
`(,tag ,attrs ,@children)))
(define (xexpr->tag*attrs*children xexpr)
(let ((tag (first xexpr))
(but-tag (rest xexpr)))
(if (empty? but-tag)
(values tag '() '())
(let ((next (first but-tag)))
(if (attrs? next)
(values tag next (rest but-tag))
(values tag '() but-tag))))))
(define (wrap-each-in-list tag elts)
(filter-map (lambda (e) (and e `(,tag ,e))) elts))
(define (wrap-each-in-list-with-attrs tag attrs elts)
(filter-map (lambda (e) (and e `(,tag ,attrs ,e))) elts))
(define (web-link label url #:class (class #f) #:extra-attrs (extra-attrs '()))
`(a ((href ,url) ,@(append (if class `((class ,class)) '())
extra-attrs))
,label))
(define (raw-str str)
(make-cdata #f #f str))