From 8458130d0e3e3a2fb20c3dbd8877484c9f277197 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 9 Nov 2014 11:37:49 -0500 Subject: [PATCH] Reloadable code. --- Makefile | 2 +- src/entrypoint.rkt | 28 ++- src/jsonp-client.rkt | 2 +- src/main.rkt | 11 +- src/packages.rkt | 211 ++++++++++--------- src/reload.rkt | 85 ++++++++ src/sessions.rkt | 23 +- src/signals.rkt | 5 + src/site.rkt | 492 ++++++++++++++++++++++--------------------- 9 files changed, 500 insertions(+), 359 deletions(-) create mode 100644 src/reload.rkt diff --git a/Makefile b/Makefile index 8b52707..f4bf189 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ stop-service: sudo svc -d /etc/service/$$(basename $$(pwd)) compile: - raco make src/main.rkt + raco make src/main.rkt src/site.rkt clean: find . -depth -type d -iname compiled -exec rm -rf {} \; diff --git a/src/entrypoint.rkt b/src/entrypoint.rkt index 1b927b0..b3127a6 100644 --- a/src/entrypoint.rkt +++ b/src/entrypoint.rkt @@ -1,14 +1,19 @@ #lang racket/base -(provide start-service) +(provide (struct-out entry-point) ;; from reload.rkt + make-entry-point ;; from reload.rkt + start-service) (require web-server/servlet-env) (require web-server/managers/lru) +(require "signals.rkt") +(require "reload.rkt") -(define (start-service #:port [port 8443] - #:ssl? [ssl? #t] - request-handler-function - on-continuation-expiry) +(define (start-service* #:port [port 8443] + #:ssl? [ssl? #t] + request-handler-function + on-continuation-expiry) + (start-restart-signal-watcher) (serve/servlet request-handler-function #:launch-browser? #f #:quit? #f @@ -24,3 +29,16 @@ #:ssl-cert (and ssl? (build-path (current-directory) "../server-cert.pem")) #:ssl-key (and ssl? (build-path (current-directory) "../private-key.pem")) #:servlet-regexp #rx"")) + +(define (start-service #:port [port 8443] + #:ssl? [ssl? #t] + #:reloadable? [reloadable? #t] + request-handler-entry-point + on-continuation-expiry-entry-point) + (when (not reloadable?) + (set-reload-poll-interval! #f)) + (reload!) + (start-service* #:port port + #:ssl? ssl? + (lambda (req) ((entry-point-value request-handler-entry-point) req)) + (lambda (req) ((entry-point-value on-continuation-expiry-entry-point) req)))) diff --git a/src/jsonp-client.rkt b/src/jsonp-client.rkt index 48830e4..9ad694a 100644 --- a/src/jsonp-client.rkt +++ b/src/jsonp-client.rkt @@ -41,7 +41,7 @@ (define request-url (string->url (format "~a~a?~a" - (jsonp-baseurl) + (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")) site-relative-url (alist->form-urlencoded parameters)))) (define-values (body-port response-headers) (get-pure-port/headers request-url)) diff --git a/src/main.rkt b/src/main.rkt index 31a82b9..82e7080 100644 --- a/src/main.rkt +++ b/src/main.rkt @@ -2,11 +2,6 @@ (module+ main (require "entrypoint.rkt") - (require "signals.rkt") - (start-restart-signal-watcher) - ;; (start-reloadable-service "site.rkt" - ;; 'request-handler - ;; 'on-continuation-expiry) - (require "site.rkt") - (start-service request-handler on-continuation-expiry) - ) + (start-service #:reloadable? (getenv "SITE_RELOADABLE") + (make-entry-point 'request-handler "site.rkt") + (make-entry-point 'on-continuation-expiry "site.rkt"))) diff --git a/src/packages.rkt b/src/packages.rkt index 0038419..9f9b9a9 100644 --- a/src/packages.rkt +++ b/src/packages.rkt @@ -21,6 +21,7 @@ (require web-server/private/gzip) (require (only-in web-server/private/util exn->string)) (require net/url) +(require "reload.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -38,6 +39,11 @@ (define package-fetch-interval (* 300 1000)) ;; 300 seconds = 300,000 milliseconds = 5 minutes (define base-bogus-timeout (* 5 1000)) ;; 5 seconds +(struct package-manager-state (local-packages + all-tags + next-fetch-deadline + next-bogus-timeout) #:prefab) + (define (fetch-remote-packages) (log-info "Fetching package list from ~a" package-index-url) (define result @@ -54,110 +60,127 @@ (define (tombstone? pkg) (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))) + (struct-copy package-manager-state state + [next-fetch-deadline (+ (current-inexact-milliseconds) package-fetch-interval)])) + (define (package-manager) - (define remote-packages (hash)) - (define all-tags* (set)) - (define local-packages (hash)) - (define next-fetch-deadline 0) - (define next-bogus-timeout base-bogus-timeout) + (with-handlers* ((exn:fail? (lambda (e) + (log-error "*** PACKAGE MANAGER CRASHED ***\n~a" + (exn->string e)) + (sleep 5) + (package-manager)))) + (package-manager-main (package-manager-state (hash) + (set) + 0 + base-bogus-timeout)))) - (define (asynchronously-fetch-remote-packages!) - (thread (lambda () - (define raw-remote-packages (fetch-remote-packages)) - (if (hash? raw-remote-packages) - (begin (set! next-bogus-timeout base-bogus-timeout) - (manager-rpc 'refresh-packages! raw-remote-packages)) - (begin (set! next-fetch-deadline (+ (current-inexact-milliseconds) - next-bogus-timeout)) - (log-info "Will retry in ~a ms" next-bogus-timeout) - (set! next-bogus-timeout (min package-fetch-interval - (* next-bogus-timeout 1.618))) - (manager-rpc 'ping))))) - (set! next-fetch-deadline (+ (current-inexact-milliseconds) package-fetch-interval))) +(define (refresh-packages raw-remote-packages state) + (define local-packages (package-manager-state-local-packages state)) + (define remote-packages (for/hash (((package-name pkg) (in-hash raw-remote-packages))) + (values package-name + (hash-set pkg '_SEARCHABLE-TEXT_ + (pkg->searchable-text pkg))))) + (define all-package-names (set-union (list->set (hash-keys local-packages)) + (list->set (hash-keys remote-packages)))) + (define new-local-packages + (for/fold ((acc (hash))) ((package-name all-package-names)) + (define local-pkg (hash-ref local-packages package-name (lambda () #f))) + (define remote-pkg (hash-ref remote-packages package-name (lambda () #f))) + (define new-local-pkg + (cond + [(not local-pkg) remote-pkg] + [(and (eq? local-pkg 'tombstone) (not remote-pkg)) #f] + [(eq? local-pkg 'tombstone) 'tombstone] + [(> (or (@ remote-pkg last-edit) 0) (or (@ local-pkg last-edit) 0)) remote-pkg] + [else local-pkg])) + (if new-local-pkg + (hash-set acc package-name new-local-pkg) + acc))) + (rebuild-all-tags (struct-copy package-manager-state state + [local-packages new-local-packages]))) - (define (refresh-packages! raw-remote-packages) - (set! remote-packages - (for/hash (((package-name pkg) (in-hash raw-remote-packages))) - (values package-name - (hash-set pkg '_SEARCHABLE-TEXT_ (pkg->searchable-text pkg))))) - (define all-package-names (set-union (list->set (hash-keys local-packages)) - (list->set (hash-keys remote-packages)))) - (set! local-packages - (for/fold ((acc (hash))) ((package-name all-package-names)) - (define local-pkg (hash-ref local-packages package-name (lambda () #f))) - (define remote-pkg (hash-ref remote-packages package-name (lambda () #f))) - (define new-local-pkg - (cond - [(not local-pkg) remote-pkg] - [(and (eq? local-pkg 'tombstone) (not remote-pkg)) #f] - [(eq? local-pkg 'tombstone) 'tombstone] - [(> (or (@ remote-pkg last-edit) 0) (or (@ local-pkg last-edit) 0)) remote-pkg] - [else local-pkg])) - (if new-local-pkg - (hash-set acc package-name new-local-pkg) - acc))) - (rebuild-all-tags!)) +(define (rebuild-all-tags state) + (struct-copy package-manager-state state + [all-tags + (for/fold ((ts (set))) + ((pkg (in-hash-values (package-manager-state-local-packages state)))) + (set-union ts (list->set (or (@ pkg tags) '()))))])) - (define (rebuild-all-tags!) - (set! all-tags* - (for/fold ((ts (set))) ((pkg (in-hash-values local-packages))) - (set-union ts (list->set (or (@ pkg tags) '())))))) +(define (replace-package old-pkg new-pkg state) + (define local-packages (package-manager-state-local-packages state)) + (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))) + local-packages) + (string->symbol (@ (or new-pkg old-pkg) name)) + (or new-pkg 'tombstone))]))) - (define (replace-package! old-pkg new-pkg) - (set! local-packages - (hash-set (if old-pkg - (hash-remove local-packages (string->symbol (@ old-pkg name))) - local-packages) - (string->symbol (@ (or new-pkg old-pkg) name)) - (or new-pkg 'tombstone))) - (rebuild-all-tags!)) +(define (delete-package package-name state) + (define local-packages (package-manager-state-local-packages state)) + (if (hash-has-key? local-packages package-name) + (struct-copy package-manager-state state + [local-packages (hash-set local-packages package-name 'tombstone)]) + state)) - (define (delete-package! package-name) - (when (hash-has-key? local-packages package-name) - (set! local-packages (hash-set local-packages package-name 'tombstone)))) +(define (package-manager-main state) + (match-define (package-manager-state local-packages + all-tags + next-fetch-deadline + next-bogus-timeout) state) + (match (sync (handle-evt (thread-receive-evt) + (lambda (_) (thread-receive))) + (handle-evt (alarm-evt next-fetch-deadline) + (lambda (_) (list #f 'refresh-packages!)))) + [(cons ch request) + (define-values (reply new-state) + (match request + [(list 'next-fetch-deadline) + (values next-fetch-deadline state)] + [(list 'refresh-packages!) + (values (void) (asynchronously-fetch-remote-packages state))] + [(list 'refresh-packages! (? hash? raw)) + (values (void) + (struct-copy package-manager-state (refresh-packages raw state) + [next-bogus-timeout base-bogus-timeout]))] + [(list 'refresh-packages! _) + (log-info "Will retry in ~a ms" next-bogus-timeout) + (values (void) + (struct-copy package-manager-state state + [next-fetch-deadline + (+ (current-inexact-milliseconds) + next-bogus-timeout)] + [next-bogus-timeout + (min package-fetch-interval + (* next-bogus-timeout 1.618))]))] + [(list 'packages) + (values local-packages state)] + [(list 'all-package-names) + (values (hash-keys local-packages) state)] + [(list 'all-tags) + (values all-tags state)] + [(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))])) + (when ch (channel-put ch reply)) + (package-manager-main new-state)])) - (with-handlers ((exn:fail? (lambda (e) - (log-error "*** PACKAGE MANAGER CRASHED ***\n~a" - (exn->string e)) - (sleep 5) - (package-manager)))) - (let loop () - (match (sync (handle-evt (thread-receive-evt) - (lambda (_) (thread-receive))) - (handle-evt (alarm-evt next-fetch-deadline) - (lambda (_) (list #f 'refresh-packages!)))) - [(cons ch request) - (define reply (match request - [(list 'ping) - 'pong] - [(list 'next-fetch-deadline) - next-fetch-deadline] - [(list 'refresh-packages!) - (asynchronously-fetch-remote-packages!)] - [(list 'refresh-packages! raw) - (refresh-packages! raw)] - [(list 'packages) - local-packages] - [(list 'all-package-names) - (hash-keys local-packages)] - [(list 'all-tags) - all-tags*] - [(list 'package-detail name) - (define pkg (hash-ref local-packages name (lambda () #f))) - (if (tombstone? pkg) - #f - pkg)] - [(list 'replace-package! old-pkg new-pkg) - (replace-package! old-pkg new-pkg)] - [(list 'delete-package! package-name) (delete-package! package-name)])) - (when ch (channel-put ch reply)) - (loop)])))) - -(define package-manager-thread (thread package-manager)) +(define package-manager-thread + (make-persistent-state 'package-manager-thread + (lambda () (thread package-manager)))) (define (manager-rpc . request) (define ch (make-channel)) - (thread-send package-manager-thread (cons ch request)) + (thread-send (package-manager-thread) (cons ch request)) (channel-get ch)) (define (all-package-names) (manager-rpc 'all-package-names)) diff --git a/src/reload.rkt b/src/reload.rkt new file mode 100644 index 0000000..f629523 --- /dev/null +++ b/src/reload.rkt @@ -0,0 +1,85 @@ +#lang racket/base + +(provide (struct-out entry-point) + reload-poll-interval + set-reload-poll-interval! + reload-failure-retry-delay + reload! + make-entry-point + lookup-entry-point + make-persistent-state) + +(require racket/match) +(require racket/rerequire) +(require (only-in web-server/private/util exn->string)) + +(define reload-poll-interval 0.5) ;; seconds +(define reload-failure-retry-delay (make-parameter 10)) ;; seconds + +(struct entry-point (name module-path identifier-symbol [value #:mutable]) #:prefab) + +(define entry-points (make-hash)) +(define persistent-state (make-hash)) + +(define (set-reload-poll-interval! v) + (set! reload-poll-interval v)) + +(define (reloader-main) + (let loop () + (match (sync (handle-evt (thread-receive-evt) + (lambda (_) (thread-receive))) + (if reload-poll-interval + (handle-evt (alarm-evt (+ (current-inexact-milliseconds) + (* reload-poll-interval 1000))) + (lambda (_) (list #f 'reload))) + never-evt)) + [(list ch 'reload) + (define result (do-reload!)) + (when (not result) (sleep (reload-failure-retry-delay))) + (when ch (channel-put ch result))]) + (loop))) + +(define reloader-thread (thread reloader-main)) + +(define (reloader-rpc . request) + (define ch (make-channel)) + (thread-send reloader-thread (cons ch request)) + (channel-get ch)) + +(define (reload!) (reloader-rpc 'reload)) + +;; Only to be called from reloader-main +(define (do-reload!) + (with-handlers ((exn:fail? + (lambda (e) + (log-error "*** WHILE RELOADING CODE***\n~a" (exn->string e)) + #f))) + (for ((e (in-hash-values entry-points))) + (match-define (entry-point _ module-path identifier-symbol _) e) + (dynamic-rerequire module-path #:verbosity 'all) + (set-entry-point-value! e (dynamic-require module-path identifier-symbol))) + #t)) + +(define (make-entry-point name module-path [identifier-symbol name]) + (when (hash-has-key? entry-points name) + (error 'make-entry-point "Duplicate entry-point name ~a" name)) + (define e (entry-point name module-path identifier-symbol #f)) + (hash-set! entry-points name e) + e) + +(define (lookup-entry-point name) + (hash-ref entry-points name)) + +(define (make-persistent-state name initial-value-thunk) + (hash-ref persistent-state + name + (lambda () + (define value (initial-value-thunk)) + (define handler + (case-lambda + [() value] + [(new-value) + (set! value new-value) + value])) + (hash-set! persistent-state name handler) + handler))) diff --git a/src/sessions.rkt b/src/sessions.rkt index 256e158..175a41d 100644 --- a/src/sessions.rkt +++ b/src/sessions.rkt @@ -10,13 +10,14 @@ lookup-session) (require "randomness.rkt") +(require "reload.rkt") (define current-session (make-parameter #f)) (define session-lifetime (make-parameter (* 7 24 60 60 1000))) ;; one week in milliseconds -(struct session (key expiry email password) #:transparent) +(struct session (key expiry email password) #:prefab) -(define sessions (make-hash)) +(define sessions (make-persistent-state 'session-store (lambda () (make-hash)))) (define (current-email) (define s (current-session)) @@ -24,15 +25,16 @@ (define (expire-sessions!) (define now (current-inexact-milliseconds)) - (for ((session-key (hash-keys sessions))) - (define s (hash-ref sessions session-key (lambda () #f))) + (define ss (sessions)) + (for ((session-key (hash-keys ss))) + (define s (hash-ref ss session-key (lambda () #f))) (when (and s (<= (session-expiry s) now)) - (hash-remove! sessions session-key)))) + (hash-remove! ss session-key)))) (define (create-session! email password) (expire-sessions!) (define session-key (bytes->string/utf-8 (random-bytes/base64 32))) - (hash-set! sessions + (hash-set! (sessions) session-key (session session-key (+ (current-inexact-milliseconds) (session-lifetime)) @@ -41,15 +43,16 @@ session-key) (define (destroy-session! session-key) - (hash-remove! sessions session-key)) + (hash-remove! (sessions) session-key)) (define (lookup-session/touch! session-key) - (define s (hash-ref sessions session-key (lambda () #f))) + (log-info "Looking up session ~a" session-key) + (define s (hash-ref (sessions) session-key (lambda () #f))) (and s (let ((s1 (struct-copy session s [expiry (+ (current-inexact-milliseconds) (session-lifetime))]))) - (hash-set! sessions session-key s1) + (hash-set! (sessions) session-key s1) s1))) (define (lookup-session session-key) - (hash-ref sessions session-key (lambda () #f))) + (hash-ref (sessions) session-key (lambda () #f))) diff --git a/src/signals.rkt b/src/signals.rkt index c7e692d..5f55d63 100644 --- a/src/signals.rkt +++ b/src/signals.rkt @@ -4,6 +4,8 @@ (provide poll-signal start-restart-signal-watcher) +(require "reload.rkt") + (define (poll-signal signal-file-name message handler) (when (file-exists? signal-file-name) (log-info message) @@ -24,5 +26,8 @@ (poll-signal "../signals/.restart-required" "Restart signal received - attempting to restart" (lambda () (exit 0))) + (poll-signal "../signals/.reload" + "Reload signal received - attempting to reload code" + (lambda () (reload!))) (sleep 0.5) (loop))))) diff --git a/src/site.rkt b/src/site.rkt index a38e453..004006e 100644 --- a/src/site.rkt +++ b/src/site.rkt @@ -19,20 +19,26 @@ (define nav-index "Package Index") (define nav-search "Search") -(bootstrap-navbar-header - `(a ((href "http://www.racket-lang.org/")) - (img ((src "/logo-and-text.png") - (height "60") - (alt "Racket Package Index"))))) +(define navbar-header + `(a ((href "http://www.racket-lang.org/")) + (img ((src "/logo-and-text.png") + (height "60") + (alt "Racket Package Index"))))) -(bootstrap-navigation `((,nav-index "/") - (,nav-search "/search") - ;; ((div ,(glyphicon 'download-alt) - ;; " Download") - ;; "http://download.racket-lang.org/") - )) +(define navigation `((,nav-index "/") + (,nav-search "/search") + ;; ((div ,(glyphicon 'download-alt) + ;; " Download") + ;; "http://download.racket-lang.org/") + )) -(jsonp-baseurl "https://pkgd.racket-lang.org") +(define backend-baseurl "https://pkgd.racket-lang.org") + +(define default-empty-source-url "git://github.com//") +(define COOKIE "pltsession") +(define recent-seconds (* 2 24 60 60)) ;; two days + +(struct draft-package (old-name name description authors tags versions) #:prefab) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -51,18 +57,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define default-empty-source-url "git://github.com//") -(define COOKIE "pltsession") -(define recent-seconds (* 2 24 60 60)) ;; two days - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define-syntax-rule (authentication-wrap #:request request body ...) (authentication-wrap* #f request (lambda () body ...))) (define-syntax-rule (authentication-wrap/require-login #:request request body ...) (authentication-wrap* #t request (lambda () body ...))) +(define-syntax-rule (with-site-config body ...) + (parameterize ((bootstrap-navbar-header navbar-header) + (bootstrap-navigation navigation) + (jsonp-baseurl backend-baseurl)) + body ...)) + (define clear-session-cookie (make-cookie COOKIE "" #:path "/" @@ -90,7 +96,8 @@ (if new-session-key (list (make-cookie COOKIE new-session-key #:path "/" #:secure? #t)) (list clear-session-cookie)))) - (bootstrap-redirect (url->string (request-uri request))))) + (with-site-config + (bootstrap-redirect (url->string (request-uri request)))))) (send/suspend/dispatch (lambda (embed-url) @@ -137,7 +144,7 @@ #:path "/" #:secure? #t)) (list)))) - (body))))))) + (with-site-config (body)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -191,26 +198,27 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (login-page [error-message #f]) - (send/suspend/dispatch - (lambda (embed-url) - (bootstrap-response "Login" - `(form ((class "form-horizontal") - (method "post") - (action ,(embed-url process-login-credentials)) - (role "form")) - ,(form-group 2 2 (label "email" "Email address") - 0 5 (email-input "email")) - ,(form-group 2 2 (label "password" "Password:") - 0 5 (password-input "password")) - ,(form-group 4 5 - `(a ((href ,(embed-url (lambda (req) (register-page))))) - "Need to reset your password?")) - ,@(maybe-splice - error-message - (form-group 4 5 - `(div ((class "alert alert-danger")) - (p ,error-message)))) - ,(form-group 4 5 (primary-button "Log in"))))))) + (with-site-config + (send/suspend/dispatch + (lambda (embed-url) + (bootstrap-response "Login" + `(form ((class "form-horizontal") + (method "post") + (action ,(embed-url process-login-credentials)) + (role "form")) + ,(form-group 2 2 (label "email" "Email address") + 0 5 (email-input "email")) + ,(form-group 2 2 (label "password" "Password:") + 0 5 (password-input "password")) + ,(form-group 4 5 + `(a ((href ,(embed-url (lambda (req) (register-page))))) + "Need to reset your password?")) + ,@(maybe-splice + error-message + (form-group 4 5 + `(div ((class "alert alert-danger")) + (p ,error-message)))) + ,(form-group 4 5 (primary-button "Log in")))))))) (define (authenticate-with-server! email password code) (jsonp-rpc! #:sensitive? #t @@ -236,41 +244,42 @@ (define (register-page #:email [email ""] #:code [code ""] #:error-message [error-message #f]) - (send/suspend/dispatch - (lambda (embed-url) - (bootstrap-response "Register/Reset Account" - #:title-element "" - `(div - (h1 "Got a registration or reset code?") - (p "Great! Enter it below, with your chosen password, to log in.") - (form ((class "form-horizontal") - (method "post") - (action ,(embed-url apply-account-code)) - (role "form")) - ,(form-group 2 2 (label "email" "Email address") - 0 5 (email-input "email" email)) - ,(form-group 2 2 (label "code" "Code") - 0 5 (text-input "code" code)) - ,(form-group 2 2 (label "password" "Password") - 0 5 (password-input "password")) - ,(form-group 2 2 (label "password" "Confirm password") - 0 5 (password-input "confirm_password")) - ,@(maybe-splice - error-message - (form-group 4 5 - `(div ((class "alert alert-danger")) - (p ,error-message)))) - ,(form-group 4 5 (primary-button "Continue")))) - `(div - (h1 "Need a code?") - (p "Enter your email address below, and we'll send you one.") - (form ((class "form-horizontal") - (method "post") - (action ,(embed-url notify-of-emailing)) - (role "form")) - ,(form-group 2 2 (label "email" "Email address") - 0 5 (email-input "email_for_code")) - ,(form-group 4 5 (primary-button "Email me a code")))))))) + (with-site-config + (send/suspend/dispatch + (lambda (embed-url) + (bootstrap-response "Register/Reset Account" + #:title-element "" + `(div + (h1 "Got a registration or reset code?") + (p "Great! Enter it below, with your chosen password, to log in.") + (form ((class "form-horizontal") + (method "post") + (action ,(embed-url apply-account-code)) + (role "form")) + ,(form-group 2 2 (label "email" "Email address") + 0 5 (email-input "email" email)) + ,(form-group 2 2 (label "code" "Code") + 0 5 (text-input "code" code)) + ,(form-group 2 2 (label "password" "Password") + 0 5 (password-input "password")) + ,(form-group 2 2 (label "password" "Confirm password") + 0 5 (password-input "confirm_password")) + ,@(maybe-splice + error-message + (form-group 4 5 + `(div ((class "alert alert-danger")) + (p ,error-message)))) + ,(form-group 4 5 (primary-button "Continue")))) + `(div + (h1 "Need a code?") + (p "Enter your email address below, and we'll send you one.") + (form ((class "form-horizontal") + (method "post") + (action ,(embed-url notify-of-emailing)) + (role "form")) + ,(form-group 2 2 (label "email" "Email address") + 0 5 (email-input "email_for_code")) + ,(form-group 4 5 (primary-button "Email me a code"))))))))) (define (apply-account-code request) (define-form-bindings request (email code password confirm_password)) @@ -304,16 +313,17 @@ (summarise-code-emailing "Account registration/reset code emailed" email_for_code)) (define (summarise-code-emailing reason email) - (send/suspend/dispatch - (lambda (embed-url) - (bootstrap-response reason - `(p - "We've emailed an account registration/reset code to " - (code ,email) ". Please check your email and then click " - "the button to continue:") - `(a ((class "btn btn-primary") - (href ,(embed-url (lambda (req) (register-page))))) - "Enter your code"))))) + (with-site-config + (send/suspend/dispatch + (lambda (embed-url) + (bootstrap-response reason + `(p + "We've emailed an account registration/reset code to " + (code ,email) ". Please check your email and then click " + "the button to continue:") + `(a ((class "btn btn-primary") + (href ,(embed-url (lambda (req) (register-page))))) + "Enter your code")))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -445,9 +455,10 @@ (package-summary-table package-name-list))))) (define (logout-page request) - (parameterize ((bootstrap-cookies (list clear-session-cookie))) - (when (current-session) (destroy-session! (session-key (current-session)))) - (bootstrap-redirect (named-url main-page)))) + (with-site-config + (parameterize ((bootstrap-cookies (list clear-session-cookie))) + (when (current-session) (destroy-session! (session-key (current-session)))) + (bootstrap-redirect (named-url main-page))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -616,8 +627,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(struct draft-package (old-name name description authors tags versions) #:transparent) - (define (edit-package-page request [package-name-str ""]) (authentication-wrap/require-login #:request request @@ -655,161 +664,163 @@ (cons default (remove default alist))) (define (package-form error-message draft) - (send/suspend/dispatch - (lambda (embed-url) + (with-site-config + (send/suspend/dispatch + (lambda (embed-url) - (define (build-versions-table) - `(table ((class "package-versions")) - (tr (th "Version") - (th "Source")) - ,@(for/list ((v (put-default-first - (draft-package-versions draft)))) - (match-define (list version source) v) - (define (control-name c) (format "version__~a__~a" version c)) - (define (group-name c) (format "version__~a__~a__group" version c)) - (define (textfield name label-text value [placeholder ""]) - (row #:id (group-name name) - 0 3 - (and label-text (label (control-name name) label-text)) - 0 (if label-text 9 12) - (text-input (control-name name) value #:placeholder placeholder))) - (define-values (source-type simple-url g-host g-user g-project g-branch) - (match source - [(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?" - (list _ u p _ b)) - (values "github" "" "github.com" u p (if (equal? b "master") "" (or b #f)))] - [(pregexp #px"git://([^/]*)/([^/]*)/([^/]*)(/([^/]*)/?)?" - (list _ h u p _ b)) - (values "git" "" h u p (if (equal? b "master") "" (or b "")))] - [_ - (values "simple" source "" "" "" "")])) - `(tr - (td ,version - ,@(maybe-splice - (not (equal? version "default")) - " " - `(button ((class "btn btn-danger btn-xs") + (define (build-versions-table) + `(table ((class "package-versions")) + (tr (th "Version") + (th "Source")) + ,@(for/list ((v (put-default-first + (draft-package-versions draft)))) + (match-define (list version source) v) + (define (control-name c) (format "version__~a__~a" version c)) + (define (group-name c) (format "version__~a__~a__group" version c)) + (define (textfield name label-text value [placeholder ""]) + (row #:id (group-name name) + 0 3 + (and label-text (label (control-name name) label-text)) + 0 (if label-text 9 12) + (text-input (control-name name) value #:placeholder placeholder))) + (define-values (source-type simple-url g-host g-user g-project g-branch) + (match source + [(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?" + (list _ u p _ b)) + (values "github" "" "github.com" u p (if (equal? b "master") "" (or b #f)))] + [(pregexp #px"git://([^/]*)/([^/]*)/([^/]*)(/([^/]*)/?)?" + (list _ h u p _ b)) + (values "git" "" h u p (if (equal? b "master") "" (or b "")))] + [_ + (values "simple" source "" "" "" "")])) + `(tr + (td ,version + ,@(maybe-splice + (not (equal? version "default")) + " " + `(button ((class "btn btn-danger btn-xs") + (type "submit") + (name "action") + (value ,(control-name "delete"))) + ,(glyphicon 'trash)))) + (td ,(row + 0 3 `(div ((id ,(group-name "type"))) + (select ((class "package-version-source-type") + (data-packageversion ,version) + (name ,(control-name "type"))) + ,(package-source-option source-type + "github" + "Github Repository") + ,(package-source-option source-type + "git" + "Git Repository") + ,(package-source-option source-type + "simple" + "Simple URL"))) + 0 9 `(div ((id ,(group-name "fields"))) + (div ((id ,(group-name "urlpreview")) + (class "row")) + (div ((class "col-sm-3")) + ,(label #f "URL preview")) + (div ((class "col-sm-9")) + (span ((class "form-control disabled") + (disabled "disabled") + (id ,(control-name "urlpreview")))))) + ,(textfield "simple_url" #f simple-url) + ,(textfield "g_host" "Repo Host" g-host) + ,(textfield "g_user" "Repo User" g-user) + ,(textfield "g_project" "Repo Project" g-project) + ,(textfield "g_branch" "Repo Branch" g-branch "master")))))) + + (tr (td ((colspan "2")) + (div ((class "form-inline")) + ,(text-input "new_version" #:placeholder "x.y.z") + " " + (button ((class "btn btn-success btn-xs") (type "submit") (name "action") - (value ,(control-name "delete"))) - ,(glyphicon 'trash)))) - (td ,(row - 0 3 `(div ((id ,(group-name "type"))) - (select ((class "package-version-source-type") - (data-packageversion ,version) - (name ,(control-name "type"))) - ,(package-source-option source-type - "github" - "Github Repository") - ,(package-source-option source-type - "git" - "Git Repository") - ,(package-source-option source-type - "simple" - "Simple URL"))) - 0 9 `(div ((id ,(group-name "fields"))) - (div ((id ,(group-name "urlpreview")) - (class "row")) - (div ((class "col-sm-3")) - ,(label #f "URL preview")) - (div ((class "col-sm-9")) - (span ((class "form-control disabled") - (disabled "disabled") - (id ,(control-name "urlpreview")))))) - ,(textfield "simple_url" #f simple-url) - ,(textfield "g_host" "Repo Host" g-host) - ,(textfield "g_user" "Repo User" g-user) - ,(textfield "g_project" "Repo Project" g-project) - ,(textfield "g_branch" "Repo Branch" g-branch "master")))))) + (value "add_version")) + ,(glyphicon 'plus-sign) " Add new version")))) + )) - (tr (td ((colspan "2")) - (div ((class "form-inline")) - ,(text-input "new_version" #:placeholder "x.y.z") - " " - (button ((class "btn btn-success btn-xs") - (type "submit") - (name "action") - (value "add_version")) - ,(glyphicon 'plus-sign) " Add new version")))) - )) - - (parameterize ((bootstrap-page-scripts '("/editpackage.js"))) - (define old-name (draft-package-old-name draft)) - (define has-old-name? (not (equal? old-name ""))) - (bootstrap-response (if has-old-name? - (format "Editing package ~a" old-name) - "Creating a new package") - (if error-message - `(div ((class "alert alert-danger")) - ,(glyphicon 'exclamation-sign) " " ,error-message) - "") - `(form ((id "edit-package-form") - (method "post") - (action ,(embed-url (update-draft draft))) - (role "form")) - (div ((class "container")) ;; TODO: remove?? - (div ((class "row")) - (div ((class "form-group col-sm-6")) - ,(label "name" "Package Name") - ,(text-input "name" (~a (draft-package-name draft)))) - (div ((class "form-group col-sm-6")) - ,(label "tags" "Package Tags (space-separated)") - ,(text-input "tags" (string-join - (draft-package-tags draft))))) - (div ((class "row")) - (div ((class "form-group col-sm-6")) - ,(label "description" "Package Description") - (textarea ((class "form-control") - (name "description") - (id "description")) - ,(draft-package-description draft))) - (div ((class "form-group col-sm-6")) - ,(label "authors" - "Author email addresses (one per line)") - (textarea ((class "form-control") - (name "authors") - (id "authors")) - ,(string-join (draft-package-authors draft) - "\n")))) - (div ((class "row")) - (div ((class "form-group col-sm-12")) - ,(label #f "Package Versions & Sources") - ,(build-versions-table))) - (div ((class "row")) - (div ((class "form-group col-sm-12")) - ,@(maybe-splice - has-old-name? - `(a ((class "btn btn-danger pull-right") - (href ,(embed-url - (confirm-package-deletion old-name)))) - ,(glyphicon 'trash) " Delete package") - " ") - (button ((type "submit") - (class "btn btn-primary") - (name "action") - (value "save_changes")) - ,(glyphicon 'save) " Save changes") - ,@(maybe-splice - has-old-name? - " " - `(a ((class "btn btn-default") - (href ,(named-url package-page old-name))) - "Cancel changes and return to package page")))))) - ))))) + (parameterize ((bootstrap-page-scripts '("/editpackage.js"))) + (define old-name (draft-package-old-name draft)) + (define has-old-name? (not (equal? old-name ""))) + (bootstrap-response (if has-old-name? + (format "Editing package ~a" old-name) + "Creating a new package") + (if error-message + `(div ((class "alert alert-danger")) + ,(glyphicon 'exclamation-sign) " " ,error-message) + "") + `(form ((id "edit-package-form") + (method "post") + (action ,(embed-url (update-draft draft))) + (role "form")) + (div ((class "container")) ;; TODO: remove?? + (div ((class "row")) + (div ((class "form-group col-sm-6")) + ,(label "name" "Package Name") + ,(text-input "name" (~a (draft-package-name draft)))) + (div ((class "form-group col-sm-6")) + ,(label "tags" "Package Tags (space-separated)") + ,(text-input "tags" (string-join + (draft-package-tags draft))))) + (div ((class "row")) + (div ((class "form-group col-sm-6")) + ,(label "description" "Package Description") + (textarea ((class "form-control") + (name "description") + (id "description")) + ,(draft-package-description draft))) + (div ((class "form-group col-sm-6")) + ,(label "authors" + "Author email addresses (one per line)") + (textarea ((class "form-control") + (name "authors") + (id "authors")) + ,(string-join (draft-package-authors draft) + "\n")))) + (div ((class "row")) + (div ((class "form-group col-sm-12")) + ,(label #f "Package Versions & Sources") + ,(build-versions-table))) + (div ((class "row")) + (div ((class "form-group col-sm-12")) + ,@(maybe-splice + has-old-name? + `(a ((class "btn btn-danger pull-right") + (href ,(embed-url + (confirm-package-deletion old-name)))) + ,(glyphicon 'trash) " Delete package") + " ") + (button ((type "submit") + (class "btn btn-primary") + (name "action") + (value "save_changes")) + ,(glyphicon 'save) " Save changes") + ,@(maybe-splice + has-old-name? + " " + `(a ((class "btn btn-default") + (href ,(named-url package-page old-name))) + "Cancel changes and return to package page")))))) + )))))) (define ((confirm-package-deletion package-name-str) request) - (send/suspend - (lambda (k-url) - (bootstrap-response "Confirm Package Deletion" - `(div ((class "confirm-package-deletion")) - (h2 ,(format "Delete ~a?" package-name-str)) - (p "This cannot be undone.") - (a ((class "btn btn-default") - (href ,k-url)) - "Confirm deletion"))))) - (jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str))) - (delete-package! (string->symbol package-name-str)) - (bootstrap-redirect (named-url main-page))) + (with-site-config + (send/suspend + (lambda (k-url) + (bootstrap-response "Confirm Package Deletion" + `(div ((class "confirm-package-deletion")) + (h2 ,(format "Delete ~a?" package-name-str)) + (p "This cannot be undone.") + (a ((class "btn btn-default") + (href ,k-url)) + "Confirm deletion"))))) + (jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str))) + (delete-package! (string->symbol package-name-str)) + (bootstrap-redirect (named-url main-page)))) (define ((update-draft draft0) request) (define draft (read-draft-form draft0 (request-bindings request))) @@ -817,7 +828,8 @@ (match action ["save_changes" (if (save-draft! draft) - (bootstrap-redirect (named-url package-page (~a (draft-package-name draft)))) + (with-site-config + (bootstrap-redirect (named-url package-page (~a (draft-package-name draft))))) (package-form "Save failed." ;; ^ TODO: This is the worst error message. ;; Right up there with "parse error".