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

Give names to the threads we create

Browse Source
This commit is contained in:
Tony Garnock-Jones 2018-06-01 18:01:27 +01:00
parent 2174e0ccd9
commit 8bb5a8646b
3 changed files with 29 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/daemon.rkt
View File

@ -6,19 +6,21 @@
(require (only-in racket/exn exn->string))
(define (daemonize-thunk name boot-thunk)
(lambda ()
(let reboot ()
;; We would catch exn:fail? here, but exn:pretty in the web
;; server is a subtype of exn, not of exn:fail, and that causes
;; spurious permanent daemon exits.
(with-handlers* ((exn? (lambda (e)
(log-error "*** DAEMON CRASHED: ~a ***\n~a"
name
(exn->string e))
(sleep 5)
(reboot))))
(define result (boot-thunk))
(log-warning "Daemon thread ~a exited normally (returning ~v)" name result)))))
(procedure-rename
(lambda ()
(let reboot ()
;; We would catch exn:fail? here, but exn:pretty in the web
;; server is a subtype of exn, not of exn:fail, and that causes
;; spurious permanent daemon exits.
(with-handlers* ((exn? (lambda (e)
(log-error "*** DAEMON CRASHED: ~a ***\n~a"
name
(exn->string e))
(sleep 5)
(reboot))))
(define result (boot-thunk))
(log-warning "Daemon thread ~a exited normally (returning ~v)" name result))))
(string->symbol (format "~v" name))))
(define (daemon-thread name boot-thunk)
(thread (daemonize-thunk name boot-thunk)))

9
src/packages.rkt
View File

@ -73,9 +73,12 @@
(eq? pkg 'tombstone))
(define (asynchronously-fetch-remote-packages state)
(thread (lambda ()
(define raw-remote-packages (fetch-remote-packages))
(manager-rpc 'refresh-packages! raw-remote-packages)))
(thread
(procedure-rename
(lambda ()
(define raw-remote-packages (fetch-remote-packages))
(manager-rpc 'refresh-packages! raw-remote-packages))
(string->symbol (format "~v" (list 'asynchronously-fetch-remote-packages (current-inexact-milliseconds))))))
(struct-copy package-manager-state state
[next-fetch-deadline (+ (current-inexact-milliseconds) package-fetch-interval)]))

14
src/static.rkt
View File

@ -173,12 +173,14 @@
(define (put/bytes^ p cb mt h)
(semaphore-wait put-bytes-sema)
(thread
(lambda ()
(with-handlers ((values (lambda (e)
(semaphore-post put-bytes-sema)
(raise e))))
(put/bytes p cb mt h)
(semaphore-post put-bytes-sema)))))
(procedure-rename
(lambda ()
(with-handlers ((values (lambda (e)
(semaphore-post put-bytes-sema)
(raise e))))
(put/bytes p cb mt h)
(semaphore-post put-bytes-sema)))
(string->symbol (format "~v" (list 'put/bytes^ p))))))
(define (aws-put-file! index absolute-path content-bytes mime-type [headers '()])
(define relative-path (absolute-path->relative-path absolute-path))