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

44
src/packages.rkt
View File

@ -163,22 +163,19 @@
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)
(match request
[(list 'next-fetch-deadline)
(values next-fetch-deadline state)] (values next-fetch-deadline state)]
[(list 'refresh-packages!) [('refresh-packages!)
(values (void) (asynchronously-fetch-remote-packages state))] (values (void) (asynchronously-fetch-remote-packages state))]
[(list 'refresh-packages! (? hash? raw)) [('refresh-packages! (? hash? raw))
(values (void) (values (void)
(struct-copy package-manager-state (refresh-packages raw state) (struct-copy package-manager-state (refresh-packages raw state)
[next-bogus-timeout base-bogus-timeout]))] [next-bogus-timeout base-bogus-timeout]))]
[(list 'refresh-packages! _) [('refresh-packages! _)
(log-info "Will retry in ~a ms" next-bogus-timeout) (log-info "Will retry in ~a ms" next-bogus-timeout)
(values (void) (values (void)
(struct-copy package-manager-state state (struct-copy package-manager-state state
@ -188,32 +185,30 @@
[next-bogus-timeout [next-bogus-timeout
(min package-fetch-interval (min package-fetch-interval
(* next-bogus-timeout 1.618))]))] (* next-bogus-timeout 1.618))]))]
[(list 'packages) [('packages)
(values local-packages state)] (values local-packages state)]
[(list 'all-package-names) [('all-package-names)
(values (hash-keys local-packages) state)] (values (hash-keys local-packages) state)]
[(list 'all-tags) [('all-tags)
(values all-tags state)] (values all-tags state)]
[(list 'all-formal-tags) [('all-formal-tags)
(values all-formal-tags state)] (values all-formal-tags state)]
[(list 'package-detail name) [('package-detail name)
(values (lookup-package name local-packages) state)] (values (lookup-package name local-packages) state)]
[(list 'package-batch-detail names) [('package-batch-detail names)
(values (for/list ((name names)) (lookup-package name local-packages)) state)] (values (for/list ((name names)) (lookup-package name local-packages)) state)]
[(list 'external-information name) [('external-information name)
(values (hash-ref external-information name (lambda () (hash))) state)] (values (hash-ref external-information name (lambda () (hash))) state)]
[(list 'set-external-information! name info) [('set-external-information! name info)
(values (void) (struct-copy package-manager-state state (values (void) (struct-copy package-manager-state state
[external-information [external-information
(if info (if info
(hash-set external-information name info) (hash-set external-information name info)
(hash-remove external-information name))]))] (hash-remove external-information name))]))]
[(list 'replace-package! completion-ch old-pkg new-pkg) [('replace-package! completion-ch old-pkg new-pkg)
(values (void) (replace-package completion-ch old-pkg new-pkg state))] (values (void) (replace-package completion-ch old-pkg new-pkg state))]
[(list 'delete-package! completion-ch package-name) [('delete-package! completion-ch package-name)
(values (void) (delete-package completion-ch package-name state))])) (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))