Add modify-all API support

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))
+                         (add-param (add-param parameters 'email (session-email s))
-                                       (cons 'passwd (session-password s)))
+                                    'passwd (session-password s))
-                                 parameters)
                          parameters))
-         (parameters (cons (cons 'callback callback-label) parameters)))
+         (parameters (add-param parameters 'callback callback-label)))
-    (define request-url
+    (define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")))
-      (string->url
+    (define request-url (string->url (format "~a~a?~a"
-       (format "~a~a?~a"
+                                             baseurl
-               (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))
+    (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))

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)
+       (jsonp-rpc! "/jsonp/package/modify-all"
-                                             (name . ,name)
+                   '()
-                                             (description . ,description)
+                   #:post-data
-                                             (source . ,source)))
+                   (string->bytes/utf-8
-       (andmap (lambda (t) (jsonp-rpc! "/jsonp/package/tag/add" `((pkg . ,name) (tag . ,t))))
+                    (jsexpr->string
-               added-tags)
+                     (hash 'pkg old-name
-       (andmap (lambda (t) (jsonp-rpc! "/jsonp/package/tag/del" `((pkg . ,name) (tag . ,t))))
+                           'name name
-               removed-tags)
+                           'description description
-       (andmap (lambda (a) (jsonp-rpc! "/jsonp/package/author/add" `((pkg . ,name) (author . ,a))))
+                           'source source
-               added-authors)
+                           'tags tags
-       (andmap (lambda (a) (jsonp-rpc! "/jsonp/package/author/del" `((pkg . ,name) (author . ,a))))
+                           'authors authors
-               removed-authors)
+                           'versions versions))))
-       (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)
-
        (let* ((new-pkg (or old-pkg (hash)))
               (new-pkg (hash-set new-pkg 'name name))
               (new-pkg (hash-set new-pkg 'description description))