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

Add modify-all API support

Browse Source
This commit is contained in:
Tony Garnock-Jones 2015-09-24 17:14:16 -04:00
parent 9a3b291bd3
commit 57beb91384
2 changed files with 33 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/jsonp-client.rkt
View File

@ -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))

59
src/site.rkt
View File

@ -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))