diff --git a/src/jsonp-client.rkt b/src/jsonp-client.rkt index 9ad694a..ace76b2 100644 --- a/src/jsonp-client.rkt +++ b/src/jsonp-client.rkt @@ -15,14 +15,18 @@ (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" + (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" @@ -31,20 +35,23 @@ (define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds))))) (define callback-label (format "callback~a" stamp)) (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp)) + (define (add-param ps name val) (cons (cons name val) ps)) (let* ((parameters original-parameters) (parameters (if (and include-credentials? s) - (append (list (cons 'email (session-email s)) - (cons 'passwd (session-password s))) - parameters) + (add-param (add-param parameters 'email (session-email s)) + 'passwd (session-password s)) parameters)) - (parameters (cons (cons 'callback callback-label) parameters))) - (define request-url - (string->url - (format "~a~a?~a" - (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")) - site-relative-url - (alist->form-urlencoded parameters)))) - (define-values (body-port response-headers) (get-pure-port/headers request-url)) + (parameters (add-param parameters 'callback callback-label))) + (define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set"))) + (define request-url (string->url (format "~a~a?~a" + baseurl + site-relative-url + (alist->form-urlencoded parameters)))) + (define-values (body-port response-headers) + (if post-data + (values (post-pure-port request-url post-data) + 'unknown-response-headers-because-post-pure-port-doesnt-return-them) + (get-pure-port/headers request-url))) (define raw-response (port->string body-port)) (match-define (pregexp extraction-expr (list _ json)) raw-response) (define reply (string->jsexpr json)) diff --git a/src/site.rkt b/src/site.rkt index 1a00aa1..d25d8ec 100644 --- a/src/site.rkt +++ b/src/site.rkt @@ -1070,59 +1070,28 @@ (define default-version (assoc "default" versions/default)) (define source (cadr default-version)) (define versions (remove default-version versions/default)) - (define old-pkg (package-detail (string->symbol old-name))) - - (define-values (added-tags removed-tags) - (added-and-removed (package-tags old-pkg) tags)) - (define-values (added-authors removed-authors) - (let ((old-authors (package-authors old-pkg))) - (added-and-removed (if (null? old-authors) - (list (current-email)) - old-authors) - authors))) - - (define old-versions-map (package-versions old-pkg)) - (define changed-versions - (for/fold ((acc '())) ((v versions)) - (match-define (list version-str new-source) v) - (define version-sym (string->symbol version-str)) - (define old-source (@ (@ref old-versions-map version-sym) source)) - (if (equal? old-source new-source) - acc - (cons v acc)))) - (define removed-versions - (for/list ((k (in-hash-keys old-versions-map)) - #:when (not (assoc (symbol->string k) versions/default))) ;; NB versions/default ! - (symbol->string k))) - ;; 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)))) - (jsonp-rpc! "/jsonp/package/modify" `((pkg . ,old-name) - (name . ,name) - (description . ,description) - (source . ,source))) - (andmap (lambda (t) (jsonp-rpc! "/jsonp/package/tag/add" `((pkg . ,name) (tag . ,t)))) - added-tags) - (andmap (lambda (t) (jsonp-rpc! "/jsonp/package/tag/del" `((pkg . ,name) (tag . ,t)))) - removed-tags) - (andmap (lambda (a) (jsonp-rpc! "/jsonp/package/author/add" `((pkg . ,name) (author . ,a)))) - added-authors) - (andmap (lambda (a) (jsonp-rpc! "/jsonp/package/author/del" `((pkg . ,name) (author . ,a)))) - removed-authors) - (andmap (lambda (e) (jsonp-rpc! "/jsonp/package/version/add" `((pkg . ,name) - (version . ,(car e)) - (source . ,(cadr e))))) - changed-versions) - (andmap (lambda (v) (jsonp-rpc! "/jsonp/package/version/del" `((pkg . ,name) - (version . ,v)))) - removed-versions) - + (jsonp-rpc! "/jsonp/package/modify-all" + '() + #:post-data + (string->bytes/utf-8 + (jsexpr->string + (hash 'pkg old-name + 'name name + 'description description + 'source source + 'tags tags + 'authors authors + 'versions versions)))) (let* ((new-pkg (or old-pkg (hash))) (new-pkg (hash-set new-pkg 'name name)) (new-pkg (hash-set new-pkg 'description description))