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

Hooks supporting rendering offline versions of pages

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-10 20:53:09 -05:00
parent a4f4daa445
commit d2ef8edd6a
2 changed files with 73 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/packages.rkt
View File

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

40
src/site.rkt
View File

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