From 1e2c6fe49e4245f0737f139d9af283383ca5fb05 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 27 Dec 2016 11:56:06 +1300 Subject: [PATCH] Avoid jsonp entirely. Matches pkg-index commit 9f78e88. --- src/json-rpc.rkt | 46 ++++++++++++++++++ src/jsonp-client.rkt | 109 ------------------------------------------- src/site.rkt | 25 +++++----- 3 files changed, 57 insertions(+), 123 deletions(-) create mode 100644 src/json-rpc.rkt delete mode 100644 src/jsonp-client.rkt diff --git a/src/json-rpc.rkt b/src/json-rpc.rkt new file mode 100644 index 0000000..a53e8c8 --- /dev/null +++ b/src/json-rpc.rkt @@ -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) diff --git a/src/jsonp-client.rkt b/src/jsonp-client.rkt deleted file mode 100644 index 2512c6b..0000000 --- a/src/jsonp-client.rkt +++ /dev/null @@ -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) diff --git a/src/site.rkt b/src/site.rkt index 45aa527..c53a7cd 100644 --- a/src/site.rkt +++ b/src/site.rkt @@ -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)))