diff --git a/src/packages.rkt b/src/packages.rkt index 3b7ca61..0f5f7ec 100644 --- a/src/packages.rkt +++ b/src/packages.rkt @@ -12,6 +12,7 @@ delete-package! refresh-packages! next-fetch-deadline + package-change-handler-thread packages-jsexpr) (require json) @@ -102,6 +103,10 @@ (> (or (@ remote-pkg last-edit) 0) (or (@ local-pkg last-edit) 0))) remote-pkg] [else local-pkg])) + (when (not (equal? new-local-pkg local-pkg)) + ;; Run in a separate thread to avoid deadlock, since the + ;; renderer will undoubtably need to call the package manager. + (notify-package-change! #f package-name)) (if new-local-pkg (hash-set acc package-name new-local-pkg) acc))) @@ -121,19 +126,25 @@ ((pkg (in-hash-values (package-manager-state-local-packages state)))) (set-union ts (list->set (or (@ pkg tags) '()))))])) -(define (replace-package old-pkg new-pkg state) +(define (replace-package completion-ch old-pkg new-pkg state) (define local-packages (package-manager-state-local-packages state)) + (define old-package-name (string->symbol (@ old-pkg name))) + (define new-package-name (string->symbol (@ (or new-pkg old-pkg) name))) + (when (not (eq? old-package-name new-package-name)) + (notify-package-change! #f old-package-name)) + (notify-package-change! completion-ch new-package-name) (rebuild-all-tags (struct-copy package-manager-state state [local-packages (hash-set (if old-pkg - (hash-remove local-packages (string->symbol (@ old-pkg name))) + (hash-remove local-packages old-package-name) local-packages) - (string->symbol (@ (or new-pkg old-pkg) name)) + new-package-name (or new-pkg 'tombstone))]))) -(define (delete-package package-name state) +(define (delete-package completion-ch package-name state) (define local-packages (package-manager-state-local-packages state)) + (notify-package-change! completion-ch package-name) (if (hash-has-key? local-packages package-name) (struct-copy package-manager-state state [local-packages (hash-set local-packages package-name 'tombstone)]) @@ -181,10 +192,10 @@ [(list 'package-detail name) (define pkg (hash-ref local-packages name (lambda () #f))) (values (if (tombstone? pkg) #f pkg) state)] - [(list 'replace-package! old-pkg new-pkg) - (values (void) (replace-package old-pkg new-pkg state))] - [(list 'delete-package! package-name) - (values (void) (delete-package package-name state))])) + [(list 'replace-package! completion-ch old-pkg new-pkg) + (values (void) (replace-package completion-ch old-pkg new-pkg state))] + [(list 'delete-package! completion-ch package-name) + (values (void) (delete-package completion-ch package-name state))])) (when ch (channel-put ch reply)) (package-manager-main new-state)])) @@ -192,6 +203,19 @@ (make-persistent-state 'package-manager-thread (lambda () (daemon-thread 'package-manager package-manager)))) +;; Set to a thread in site.rkt (because the thread needs to call +;; routines only available from site.rkt) +(define package-change-handler-thread + (make-persistent-state 'package-change-handler-thread + (lambda () #f))) + +(define (notify-package-change! completion-ch package-name) + (let retry () + (if (not (package-change-handler-thread)) + (begin (sleep 0.5) + (retry)) + (thread-send (package-change-handler-thread) (list completion-ch package-name))))) + (define (manager-rpc . request) (define ch (make-channel)) (thread-send (package-manager-thread) (cons ch request)) @@ -201,8 +225,10 @@ (define (all-tags) (manager-rpc 'all-tags)) (define (all-formal-tags) (manager-rpc 'all-formal-tags)) (define (package-detail package-name) (manager-rpc 'package-detail package-name)) -(define (replace-package! old-pkg new-pkg) (manager-rpc 'replace-package! old-pkg new-pkg)) -(define (delete-package! package-name) (manager-rpc 'delete-package! package-name)) +(define (replace-package! completion-ch old-pkg new-pkg) + (manager-rpc 'replace-package! completion-ch old-pkg new-pkg)) +(define (delete-package! completion-ch package-name) + (manager-rpc 'delete-package! completion-ch package-name)) (define (refresh-packages!) (manager-rpc 'refresh-packages!)) (define (next-fetch-deadline) (manager-rpc 'next-fetch-deadline)) diff --git a/src/site.rkt b/src/site.rkt index 9931773..c671d99 100644 --- a/src/site.rkt +++ b/src/site.rkt @@ -17,6 +17,8 @@ (require "packages.rkt") (require "sessions.rkt") (require "jsonp-client.rkt") +(require "reload.rkt") +(require "daemon.rkt") (define nav-index "Package Index") (define nav-search "Search") @@ -861,7 +863,9 @@ (href ,k-url)) "Confirm deletion"))))) (jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str))) - (delete-package! (string->symbol package-name-str)) + (define completion-ch (make-channel)) + (delete-package! completion-ch (string->symbol package-name-str)) + (channel-get completion-ch) (bootstrap-redirect (named-url main-page)))) (define ((update-draft draft0) request) @@ -990,8 +994,10 @@ (new-pkg (hash-set new-pkg 'versions (friendly-versions versions/default))) (new-pkg (hash-set new-pkg 'source source)) (new-pkg (hash-set new-pkg 'search-terms (compute-search-terms new-pkg))) - (new-pkg (hash-set new-pkg '_LOCALLY_MODIFIED_ #t))) - (replace-package! old-pkg new-pkg) + (new-pkg (hash-set new-pkg '_LOCALLY_MODIFIED_ #t)) + (completion-ch (make-channel))) + (replace-package! completion-ch old-pkg new-pkg) + (channel-get completion-ch) #t))) ;; Based on (and copied from) the analogous code in meta/pkg-index/official/static.rkt @@ -1117,3 +1123,31 @@ (response/output #:mime-type #"application/json" (lambda (response-port) (write-json (packages-jsexpr) response-port)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (rerender-indexes!) + (log-info "Rerendering indexes")) + +(define (rerender-package! package-name) + (log-info "Rerendering package ~a" package-name)) + +(define (package-change-handler) + (let loop ((index-rerender-needed? #f) + (pending-completions '())) + (sync/timeout (and index-rerender-needed? + (lambda () + (rerender-indexes!) + (for ((completion-ch pending-completions)) + (channel-put completion-ch (void))) + (loop #f '()))) + (handle-evt (thread-receive-evt) + (lambda (_) + (match (thread-receive) + [(list completion-ch package-name) + (rerender-package! package-name) + (loop #t (if completion-ch + (cons completion-ch pending-completions) + pending-completions))])))))) + +(package-change-handler-thread (daemon-thread 'package-change-handler package-change-handler))