-
Notifications
You must be signed in to change notification settings - Fork 8
/
net.rkt
113 lines (97 loc) · 3.55 KB
/
net.rkt
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
;; Copyright 2011-2012 Ryan Culpepper
;; Released under the terms of the LGPL version 3 or later.
;; See the file COPYRIGHT for details.
#lang racket/base
(require racket/match
openssl
net/url
net/url-connect)
(provide get/url
head/url
delete/url
post/url
put/url
url-add-query
form-headers)
;; Turn on verification on unix systems where ca-certificates.crt exists.
(define verifying-ssl-context
(let ([ctx (ssl-make-client-context 'sslv3)])
(case (system-type 'os)
((unix)
(let ([root-ca-file "/etc/ssl/certs/ca-certificates.crt"])
(when (file-exists? root-ca-file)
(ssl-set-verify! ctx #t)
(ssl-load-verify-root-certificates! ctx root-ca-file))))
((macosx)
;; FIXME: ???
(void))
((windows)
;; FIXME: ???
(void)))
ctx))
#|
TODO: add redirect option like get-pure-port
|#
(define (do-method who url method data?
handle fail headers data ok-rx)
(let* ([url (if (string? url) (string->url url) url)]
[data (if (string? data) (string->bytes/utf-8 data) data)])
(unless (equal? (url-scheme url) "https")
(error who "insecure location (expected `https' scheme): ~e" (url->string url)))
(call/input-url url
(lambda (url)
(parameterize ((current-https-protocol
(if (ssl-client-context? (current-https-protocol))
(current-https-protocol)
verifying-ssl-context)))
(if data?
(method url data headers)
(method url headers))))
(lambda (in)
(let ([response-header (purify-port in)])
(cond [(regexp-match? ok-rx response-header)
(handle in)]
[else
(if (string? fail)
(error who "~a: ~e" fail
(read-line (open-input-string response-header) 'any))
(fail response-header in))]))))))
(define (get-code header)
(cadr (regexp-match #rx"^HTTP/1\\.. ([0-9]*)" header)))
(define std-ok-rx #rx"^HTTP/1\\.. 20.")
;; TODO: add separate rx & handler for auth failures
;; so that clients can call refresh-token
;; ----
(define (mk-no-data-method method)
(lambda (url
#:headers [headers null]
#:handle [handle void]
#:who [who 'get-url]
#:fail [fail "failed"]
#:ok-rx [ok-rx std-ok-rx])
(do-method who url method #f
handle fail headers #f ok-rx)))
(define get/url (mk-no-data-method get-impure-port))
(define head/url (mk-no-data-method head-impure-port))
(define delete/url (mk-no-data-method delete-impure-port))
(define (mk-data-method method)
(lambda (url
#:headers [headers null]
#:data [data #f]
#:handle [handle void]
#:who [who 'get-url]
#:fail [fail "failed"]
#:ok-rx [ok-rx std-ok-rx])
(do-method who url method #t
handle fail headers data ok-rx)))
(define post/url (mk-data-method post-impure-port))
(define put/url (mk-data-method put-impure-port))
;; ----
;; url-add-query : string/url alist -> url
(define (url-add-query base-url query-alist)
(match (if (string? base-url) (string->url base-url) base-url)
[(url scheme user host port path-abs? path query fragment)
(let ([query (append query query-alist)])
(url scheme user host port path-abs? path query fragment))]))
(define (form-headers)
(list "Content-Type: application/x-www-form-urlencoded"))