Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

276 lines (244 sloc) 9.494 kB
#lang scheme/base
;; This differs from web-export.ss in that these are ones that we wrote and aren't
;; included in PLT libs.
(require (file "util.scm")
xml
net/url
scheme/serialize
"web-export.ss"
"contract-lp.ss"
)
(provide request-all-bindings
;; final-prep-of-response (via contract)
xexpr->de-grouped-xexprs
wrap-each-in-list
wrap-each-in-list-with-attrs
redirect-to
web-link
img
raw-str
;; basic-response (via contract)
xexpr-if
url+query
url->string
get-url
bindings/string
find-binding
;; list-response (via contract)
response-promise?
;; single-response-promise-in-list (via contract)
;; single-response/full-in-list (via contract)
;; response-promise-to-redirect (via contract)
;; response-from-promise (via contract)
)
;;
;; list-response
;;
(define (any-responses? lst)
(any (lambda (elt)
(or (response/full? elt) (response/incremental? elt) (response/basic? elt)))
lst))
(provide/contract
(list-response (->*
;; required
((not/c any-responses?))
;; optional
(#:type bytes? #:extras list?)
;; returns
response/c)))
;;
(define (list-response content-lst #:type (type #"text/html") #:extras (extras '()))
(basic-response (append-map (lambda (content)
(map (lambda (c) (string->bytes/utf-8 (xexpr->string c)))
(xexpr->de-grouped-xexprs content)))
content-lst)
#:type type
#:extras extras))
(provide/contract
(basic-response (->*
;; required
((listof bytes?))
;; optional
(#:type bytes? #:extras (listof header?))
;; returns
response/c)))
(define (basic-response content-lst #:type (type #"text/html") #:extras (extras '()))
;; right now we always no-cache. we'll probably eventually want something more
;; subtle.
(let ((no-cache (make-header #"Cache-Control" (string->bytes/utf-8 "no-cache;"))))
(make-response/full 200 #"all good" (current-seconds)
type (cons no-cache extras)
content-lst)))
(define-serializable-struct binding/string (id))
(define-serializable-struct (binding/string:form binding/string) (value))
(define-serializable-struct (binding/string:file binding/string) (filename content))
(provide/contract
[struct binding/string ([id string?])]
[struct (binding/string:form binding/string) ([id string?]
[value string?])]
[struct (binding/string:file binding/string) ([id string?]
[filename string?]
[content bytes?])])
(define (bindings/string req [localization-function bytes->string/utf-8])
(map (lambda (binding)
(if (binding:form? binding)
(make-binding/string:form (localization-function (binding-id binding))
(localization-function (binding:form-value binding)))
(make-binding/string:file (localization-function (binding-id binding))
(localization-function (binding:file-filename binding))
(binding:file-content binding))))
(request-bindings/raw req)))
(define (find-binding field bindings)
; strait from request-struct.ss
(match bindings
[(list)
#f]
[(list-rest (and b (struct binding/string (i))) bindings)
(if (string=? field i)
b
(find-binding field bindings))]))
;; if you are doing a post, this gives you post and get vars. if a get, it's just reg.
(define (request-all-bindings req)
(append (request-bindings req)
(if (request-post-data/raw req) ; there a better way to check if it's a post?
(url-query (request-uri req))
'())))
(define (group-tag? xexpr)
(match xexpr ((list-rest 'group children) #t) (else #f)))
(define (xexpr->de-grouped-xexprs xexpr)
(cond ((not xexpr) '())
((not (list? xexpr)) (list xexpr)) ; non-xexpr response case
((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))))))
;; the wrap-each-in* fns filter out #f values from elts:
(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 ,(if (string? url) url (url->string url)))
,@(append (if class `((class ,class)) '()) extra-attrs))
,label))
;; image-file is relative to /i/
(define (img image-file #:class (class #f))
`(img ((src ,(string-append "/i/" image-file)) (border "0")
,@(splice-if class `(class ,class)))))
(define (raw-str str)
(make-cdata #f #f str))
;;
;; xexpr-if
;;
;; Use if you only want to create an xexpr if a condition is true. E.g.,
;; (ul (li "Item 1") ,(xexpr-if (= 2 2) `(li "Item 2")))
;;
(define-syntax xexpr-if
(syntax-rules ()
((_ test)
(or test ""))
((_ test body ...)
(if test (begin body ...) ""))))
;;
;; url+query
;;
;; query-alist is ((key . str) ...)
;; given query strs should *not* be url encoded (this will be done by url+query).
;;
(define (url+query url-str query-alist)
(let ((tmp-url (string->url url-str)))
(make-url (url-scheme tmp-url)
(url-user tmp-url)
(url-host tmp-url)
(url-port tmp-url)
(url-path-absolute? tmp-url)
(url-path tmp-url)
(append (url-query tmp-url) query-alist)
(url-fragment tmp-url))))
;;
;; get-url
;;
;; exn-handler: exn -> any
;;
(define (get-url url port-handler #:exn-handler (exn-handler #f))
(let ((thunk (lambda () (call/input-url (if (url? url) url (string->url url))
get-pure-port
port-handler))))
(if exn-handler
(with-handlers ((exn:fail:network? exn-handler)) (thunk))
(thunk))))
(define-struct response-promise (fn))
;;
;; response-promise-to-redirect
;;
;; A relatively low-level tool for "promising" to construct a redirect response. The issue
;; is that at the time we know we want to redirect, we don't necessarily know all the
;; headers that we might want to go into the redirect response. For example, a cookie
;; may need to be set on the client. Response promises can never make it to the top-level
;; (the web server), since they are a LeftParen concept only. Thus, the promises must
;; be "response-from-promise"'d before that happens.
;;
(provide/contract (response-promise-to-redirect (-> string? response-promise?)))
;;
(define (response-promise-to-redirect redirect-to-uri)
(make-response-promise (lambda (#:headers (h '())) (redirect-to redirect-to-uri
#:headers h))))
;;
;; response-from-promise
;;
(provide/contract
(response-from-promise (->* (response-promise?) (#:headers (listof header?)) response/c)))
;;
(define (response-from-promise r-p #:headers (headers '()))
((response-promise-fn r-p) #:headers headers))
;;
;; single-response-promise-in-list
;;
(provide/contract
(single-response-promise-in-list (-> (listof any/c) (or/c #f response-promise?))))
;;
(define (single-response-promise-in-list lst)
(and-let* (((and (length= lst 1)))
(elt (first lst))
((response-promise? elt)))
elt))
;;
;; single-response/full-in-list
;;
(provide/contract
(single-response/full-in-list (-> (listof any/c) (or/c #f response/full?))))
;;
(define (single-response/full-in-list lst)
(and-let* (((and (length= lst 1)))
(elt (first lst))
((response/full? elt)))
elt))
;;
;; final-prep-of-response
;;
(provide/contract
(final-prep-of-response (-> (or/c response/c response-promise?) response/c)))
;;
(define (final-prep-of-response response-or-promise)
(if (response-promise? response-or-promise)
(response-from-promise response-or-promise)
(let ((result (xexpr->de-grouped-xexprs response-or-promise)))
(if (and (length= result 1) (response? (first result)))
(first result)
(list-response result)))))
Jump to Line
Something went wrong with that request. Please try again.