-
Notifications
You must be signed in to change notification settings - Fork 6
/
web-support.scm
147 lines (127 loc) · 4.76 KB
/
web-support.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
#lang scheme/base
(require (file "util.scm")
(lib "xml.ss" "xml")
net/url
(planet "web.scm" ("soegaard" "web.plt" 2 1))
)
(provide request-all-bindings
final-prep-of-response
xexpr->de-grouped-xexprs
wrap-each-in-list
wrap-each-in-list-with-attrs
redirect-to
web-link
img
raw-str
with-binding ; from web.plt
list-response
basic-response
xexpr-if
url+query
url->string
get-url
)
(define (list-response content-lst #:type (type #"text/html") #:extras (extras '()))
(basic-response (append-map (lambda (content) (map xexpr->string
(xexpr->de-grouped-xexprs content)))
content-lst)
#:type type
#:extras extras))
(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)))
;; 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 (final-prep-of-response xexpr-or-response)
(let ((result (xexpr->de-grouped-xexprs xexpr-or-response)))
(if (and (length= result 1) (response? (first result)))
(first result)
(list-response 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))))))
;; 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))))