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

Another incremental step toward OTP

Browse Source
This commit is contained in:
Tony Garnock-Jones 2015-01-26 15:01:15 -05:00
parent 73daa62f6f
commit 0a2e678ca3
2 changed files with 78 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
src/daemon.rkt
View File

@ -1,9 +1,15 @@
#lang racket/base #lang racket/base
(provide daemonize-thunk (provide daemonize-thunk
daemon-thread) daemon-thread
rpc-request-evt
rpc-handler
rpc-call
rpc-cast!)
(require (only-in web-server/private/util exn->string)) (require (only-in web-server/private/util exn->string))
(require racket/match)
(define (daemonize-thunk name boot-thunk) (define (daemonize-thunk name boot-thunk)
(lambda () (lambda ()
@ -22,3 +28,27 @@
(define (daemon-thread name boot-thunk) (define (daemon-thread name boot-thunk)
(thread (daemonize-thunk name boot-thunk))) (thread (daemonize-thunk name boot-thunk)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (rpc-request-evt)
(handle-evt (thread-receive-evt)
(lambda (_) (thread-receive))))
(define-syntax-rule (rpc-handler ch-and-req [(argpat ...) body ...] ...)
(match ch-and-req
[(cons ch request)
(define-values (reply-value new-state)
(match request
[(list argpat ...) body ...]
...))
(when ch (channel-put ch reply-value))
new-state]))
(define (rpc-call thread . request)
(define ch (make-channel))
(thread-send thread (cons ch request))
(channel-get ch))
(define (rpc-cast! thread . request)
(thread-send thread (cons #f request)))

102
src/packages.rkt
View File

@ -163,57 +163,52 @@
all-formal-tags all-formal-tags
next-fetch-deadline next-fetch-deadline
next-bogus-timeout) state) next-bogus-timeout) state)
(match (sync (handle-evt (thread-receive-evt) (package-manager-main
(lambda (_) (thread-receive))) (rpc-handler (sync (rpc-request-evt)
(handle-evt (alarm-evt next-fetch-deadline) (handle-evt (alarm-evt next-fetch-deadline)
(lambda (_) (list #f 'refresh-packages!)))) (lambda (_) (list #f 'refresh-packages!))))
[(cons ch request) [('next-fetch-deadline)
(define-values (reply new-state) (values next-fetch-deadline state)]
(match request [('refresh-packages!)
[(list 'next-fetch-deadline) (values (void) (asynchronously-fetch-remote-packages state))]
(values next-fetch-deadline state)] [('refresh-packages! (? hash? raw))
[(list 'refresh-packages!) (values (void)
(values (void) (asynchronously-fetch-remote-packages state))] (struct-copy package-manager-state (refresh-packages raw state)
[(list 'refresh-packages! (? hash? raw)) [next-bogus-timeout base-bogus-timeout]))]
(values (void) [('refresh-packages! _)
(struct-copy package-manager-state (refresh-packages raw state) (log-info "Will retry in ~a ms" next-bogus-timeout)
[next-bogus-timeout base-bogus-timeout]))] (values (void)
[(list 'refresh-packages! _) (struct-copy package-manager-state state
(log-info "Will retry in ~a ms" next-bogus-timeout) [next-fetch-deadline
(values (void) (+ (current-inexact-milliseconds)
(struct-copy package-manager-state state next-bogus-timeout)]
[next-fetch-deadline [next-bogus-timeout
(+ (current-inexact-milliseconds) (min package-fetch-interval
next-bogus-timeout)] (* next-bogus-timeout 1.618))]))]
[next-bogus-timeout [('packages)
(min package-fetch-interval (values local-packages state)]
(* next-bogus-timeout 1.618))]))] [('all-package-names)
[(list 'packages) (values (hash-keys local-packages) state)]
(values local-packages state)] [('all-tags)
[(list 'all-package-names) (values all-tags state)]
(values (hash-keys local-packages) state)] [('all-formal-tags)
[(list 'all-tags) (values all-formal-tags state)]
(values all-tags state)] [('package-detail name)
[(list 'all-formal-tags) (values (lookup-package name local-packages) state)]
(values all-formal-tags state)] [('package-batch-detail names)
[(list 'package-detail name) (values (for/list ((name names)) (lookup-package name local-packages)) state)]
(values (lookup-package name local-packages) state)] [('external-information name)
[(list 'package-batch-detail names) (values (hash-ref external-information name (lambda () (hash))) state)]
(values (for/list ((name names)) (lookup-package name local-packages)) state)] [('set-external-information! name info)
[(list 'external-information name) (values (void) (struct-copy package-manager-state state
(values (hash-ref external-information name (lambda () (hash))) state)] [external-information
[(list 'set-external-information! name info) (if info
(values (void) (struct-copy package-manager-state state (hash-set external-information name info)
[external-information (hash-remove external-information name))]))]
(if info [('replace-package! completion-ch old-pkg new-pkg)
(hash-set external-information name info) (values (void) (replace-package completion-ch old-pkg new-pkg state))]
(hash-remove external-information name))]))] [('delete-package! completion-ch package-name)
[(list 'replace-package! completion-ch old-pkg new-pkg) (values (void) (delete-package completion-ch package-name state))])))
(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)]))
(define package-manager-thread (define package-manager-thread
(make-persistent-state 'package-manager-thread (make-persistent-state 'package-manager-thread
@ -234,10 +229,7 @@
(thread-send (package-change-handler-thread) (thread-send (package-change-handler-thread)
(list 'package-changed completion-ch package-name))))) (list 'package-changed completion-ch package-name)))))
(define (manager-rpc . request) (define (manager-rpc . request) (apply rpc-call (package-manager-thread) request))
(define ch (make-channel))
(thread-send (package-manager-thread) (cons ch request))
(channel-get ch))
(define (all-package-names) (manager-rpc 'all-package-names)) (define (all-package-names) (manager-rpc 'all-package-names))
(define (all-tags) (manager-rpc 'all-tags)) (define (all-tags) (manager-rpc 'all-tags))