suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Convert to basic auth for regular API

Browse Source
This commit is contained in:
Tony Garnock-Jones 2015-09-26 21:31:03 -05:00
parent 3bebf69540
commit d36e05220e
1 changed files with 27 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/jsonp-client.rkt
View File

@ -9,11 +9,17 @@
(require racket/port) (require racket/port)
(require net/url) (require net/url)
(require net/uri-codec) (require net/uri-codec)
(require net/base64)
(require json) (require json)
(require "sessions.rkt") (require "sessions.rkt")
(define jsonp-baseurl (make-parameter #f)) (define jsonp-baseurl (make-parameter #f))
(define (make-basic-auth-credentials-header username password)
(define token
(base64-encode (string->bytes/utf-8 (string-append username ":" password)) #""))
(string-append "Authorization: Basic " (bytes->string/utf-8 token)))
(define (jsonp-rpc! #:sensitive? [sensitive? #f] (define (jsonp-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t] #:include-credentials? [include-credentials? #t]
#:post-data [post-data #f] #:post-data [post-data #f]
@ -36,13 +42,7 @@
(define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds))))) (define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
(define callback-label (format "callback~a" stamp)) (define callback-label (format "callback~a" stamp))
(define extraction-expr (format "^callback~a\\((.*)\\);$" stamp)) (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
(define (add-param ps name val) (cons (cons name val) ps)) (define parameters (cons (cons 'callback callback-label) original-parameters))
(let* ((parameters original-parameters)
(parameters (if (and include-credentials? s)
(add-param (add-param parameters 'email (session-email s))
'passwd (session-password s))
parameters))
(parameters (add-param parameters 'callback callback-label)))
(define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set"))) (define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")))
(define request-url (string->url (format "~a~a?~a" (define request-url (string->url (format "~a~a?~a"
baseurl baseurl
@ -50,14 +50,19 @@
(alist->form-urlencoded parameters)))) (alist->form-urlencoded parameters))))
(define-values (body-port response-headers) (define-values (body-port response-headers)
(if post-data (if post-data
(values (post-pure-port request-url post-data) (values (post-pure-port request-url
post-data
(list (make-basic-auth-credentials-header (session-email s)
(session-password s))))
'unknown-response-headers-because-post-pure-port-doesnt-return-them) 'unknown-response-headers-because-post-pure-port-doesnt-return-them)
(get-pure-port/headers request-url))) (get-pure-port/headers request-url
(list (make-basic-auth-credentials-header (session-email s)
(session-password s))))))
(define raw-response (port->string body-port)) (define raw-response (port->string body-port))
(match-define (pregexp extraction-expr (list _ json)) raw-response) (match-define (pregexp extraction-expr (list _ json)) raw-response)
(define reply (string->jsexpr json)) (define reply (string->jsexpr json))
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply)) (unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
reply)) reply)
(define (simple-json-rpc! #:sensitive? [sensitive? #f] (define (simple-json-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t] #:include-credentials? [include-credentials? #t]