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

Avoid jsonp entirely. Matches pkg-index commit 9f78e88.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2016-12-27 11:56:06 +13:00
parent 547ef07c8b
commit 1e2c6fe49e
3 changed files with 57 additions and 123 deletions

46
src/json-rpc.rkt Normal file
View File

@ -0,0 +1,46 @@
#lang racket/base
;; Trivially simple authenticated JSON-over-HTTPS RPC.
(provide simple-json-rpc!)
(require racket/port)
(require net/url)
(require net/base64)
(require json)
(require "sessions.rkt")
(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 (simple-json-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t]
baseurl
site-relative-url
jsexpr-to-send)
(define s (current-session))
(if sensitive?
(log-info "simple-json-rpc: sensitive request ~v" site-relative-url)
(log-info "simple-json-rpc: request ~v params ~v~a"
site-relative-url
jsexpr-to-send
(if include-credentials?
(if s
" +creds"
" +creds(missing)")
"")))
(define request-urls (format "~a~a" baseurl site-relative-url))
(define request-url (string->url request-urls))
(define post-data (string->bytes/utf-8 (jsexpr->string jsexpr-to-send)))
(define req-headers
(if include-credentials?
(list (make-basic-auth-credentials-header (session-email s)
(session-password s)))
'()))
(define response-port (post-pure-port request-url post-data req-headers))
(define raw-response (port->string response-port))
(close-input-port response-port)
(define reply (string->jsexpr raw-response))
(unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
reply)

109
src/jsonp-client.rkt
View File

@ -1,109 +0,0 @@
#lang racket/base
(provide jsonp-baseurl
jsonp-rpc!
simple-json-rpc!)
(require racket/match)
(require racket/format)
(require racket/port)
(require net/url)
(require net/uri-codec)
(require net/base64)
(require json)
(require "sessions.rkt")
(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]
#:include-credentials? [include-credentials? #t]
#:post-data [post-data #f]
site-relative-url
original-parameters)
(define s (current-session))
(if sensitive?
(log-info "jsonp-rpc: sensitive request ~a" site-relative-url)
(log-info "jsonp-rpc: request ~a params ~a~a~a"
site-relative-url
original-parameters
(if post-data
(format " post-data: ~v" post-data)
"")
(if include-credentials?
(if s
" +creds"
" +creds(missing)")
"")))
(define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
(define callback-label (format "callback~a" stamp))
(define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
(define parameters (cons (cons 'callback callback-label) original-parameters))
(define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")))
(define request-urls
(format "~a~a?~a"
baseurl
site-relative-url
(alist->form-urlencoded parameters)))
(define request-url (string->url request-urls))
(define req-headers
(if include-credentials?
(list
(make-basic-auth-credentials-header (session-email s)
(session-password s)))
null))
(define-values (body-port response-headers)
(if post-data
(values (post-pure-port request-url
post-data
req-headers)
'unknown-response-headers-because-post-pure-port-doesnt-return-them)
(get-pure-port/headers request-url
req-headers)))
(define raw-response (port->string body-port))
(close-input-port body-port)
(match raw-response
[(pregexp extraction-expr (list _ json))
(define reply (string->jsexpr json))
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
reply]
[x
(error 'jsonp-rpc! "Illegal response to ~v: ~v"
(if sensitive? "REDACTED" request-urls)
(if sensitive? "REDACTED" raw-response))]))
(define (simple-json-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t]
site-relative-url
jsexpr-to-send)
(define s (current-session))
(if sensitive?
(log-info "simple-json-rpc: sensitive request ~v" site-relative-url)
(log-info "simple-json-rpc: request ~v params ~v~a"
site-relative-url
jsexpr-to-send
(if include-credentials?
(if s
" +creds"
" +creds(missing)")
"")))
(define baseurl
(or (jsonp-baseurl) (error 'simple-json-rpc! "jsonp-baseurl is not set")))
(define request-urls (format "~a~a" baseurl site-relative-url))
(define request-url (string->url request-urls))
(define post-data (string->bytes/utf-8 (jsexpr->string jsexpr-to-send)))
(define req-headers
(if include-credentials?
(list (make-basic-auth-credentials-header (session-email s)
(session-password s)))
'()))
(define response-port (post-pure-port request-url post-data req-headers))
(define raw-response (port->string response-port))
(close-input-port response-port)
(define reply (string->jsexpr raw-response))
(unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
reply)

25
src/site.rkt
View File

@ -22,7 +22,7 @@
(require "html-utils.rkt")
(require "packages.rkt")
(require "sessions.rkt")
(require "jsonp-client.rkt")
(require "json-rpc.rkt")
(require reloadable)
(require "daemon.rkt")
(require "config.rkt")
@ -158,8 +158,7 @@
(format "PkgSiteStaticBaseUrl = '~a';" static-urlprefix)
(format "IsStaticPage = ~a;" (if (rendering-static-page?)
"true"
"false"))))
(jsonp-baseurl backend-baseurl))
"false")))))
body ...))
(define clear-session-cookie (make-cookie COOKIE
@ -352,6 +351,7 @@
(define (authenticate-with-server! email password code)
(simple-json-rpc! #:sensitive? #t
#:include-credentials? #f
backend-baseurl
"/api/authenticate"
(hash 'email email
'passwd password
@ -1169,7 +1169,7 @@
(a ((class "btn btn-default")
(href ,k-url))
"Confirm deletion")))))
(jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str)))
(simple-json-rpc! backend-baseurl "/api/package/del" (hash 'pkg package-name-str))
(define completion-ch (make-channel))
(delete-package! completion-ch (string->symbol package-name-str))
(channel-get completion-ch)
@ -1262,16 +1262,11 @@
(define source (unparse-package-source (cadr default-version)))
(define versions (remove default-version versions/default))
(define old-pkg (package-detail (string->symbol old-name)))
;; name, description, and default source are updateable via /jsonp/package/modify.
;; tags are added and removed via /jsonp/package/tag/add and .../del.
;; authors are added and removed via /jsonp/package/author/add and .../del.
;; versions other than default are added and removed via /jsonp/package/version/add and .../del.
;;
;; modify-all incorporates all the add/delete stuff into a single API call.
(and (or (equal? old-name name)
;; Don't let renames stomp on existing packages
(not (package-detail (string->symbol name))))
(eq? #t (simple-json-rpc! "/api/package/modify-all"
(eq? #t (simple-json-rpc! backend-baseurl
"/api/package/modify-all"
(hash 'pkg old-name
'name name
'description description
@ -1345,7 +1340,7 @@
(define (update-my-packages-page request)
(authentication-wrap/require-login
#:request request
(jsonp-rpc! "/jsonp/update" '())
(simple-json-rpc! backend-baseurl "/api/update" (hash))
(bootstrap-response "Refresh All My Packages"
`(div
(p "All packages where you are listed as an author are now being rescanned.")
@ -1361,8 +1356,10 @@
(authentication-wrap/require-login
#:request request
(when (session-curator? (current-session))
(when (jsonp-rpc! "/jsonp/package/curate" `((pkg . ,package-name-str)
(ring . ,(number->string new-ring))))
(when (simple-json-rpc! backend-baseurl
"/api/package/curate"
(hash 'pkg package-name-str
'ring new-ring))
(define old-pkg (package-detail (string->symbol package-name-str)))
(let* ((new-pkg (hash-set old-pkg 'ring new-ring))
(completion-ch (make-channel)))