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

Reloadable code.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-09 11:37:49 -05:00
parent 5a717489d2
commit 8458130d0e
9 changed files with 500 additions and 359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -13,7 +13,7 @@ stop-service:
sudo svc -d /etc/service/$$(basename $$(pwd)) sudo svc -d /etc/service/$$(basename $$(pwd))
compile: compile:
raco make src/main.rkt raco make src/main.rkt src/site.rkt
clean: clean:
find . -depth -type d -iname compiled -exec rm -rf {} \; find . -depth -type d -iname compiled -exec rm -rf {} \;

28
src/entrypoint.rkt
View File

@ -1,14 +1,19 @@
#lang racket/base #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/servlet-env)
(require web-server/managers/lru) (require web-server/managers/lru)
(require "signals.rkt")
(require "reload.rkt")
(define (start-service #:port [port 8443] (define (start-service* #:port [port 8443]
#:ssl? [ssl? #t] #:ssl? [ssl? #t]
request-handler-function request-handler-function
on-continuation-expiry) on-continuation-expiry)
(start-restart-signal-watcher)
(serve/servlet request-handler-function (serve/servlet request-handler-function
#:launch-browser? #f #:launch-browser? #f
#:quit? #f #:quit? #f
@ -24,3 +29,16 @@
#:ssl-cert (and ssl? (build-path (current-directory) "../server-cert.pem")) #:ssl-cert (and ssl? (build-path (current-directory) "../server-cert.pem"))
#:ssl-key (and ssl? (build-path (current-directory) "../private-key.pem")) #:ssl-key (and ssl? (build-path (current-directory) "../private-key.pem"))
#:servlet-regexp #rx"")) #: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))))

2
src/jsonp-client.rkt
View File

@ -41,7 +41,7 @@
(define request-url (define request-url
(string->url (string->url
(format "~a~a?~a" (format "~a~a?~a"
(jsonp-baseurl) (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set"))
site-relative-url site-relative-url
(alist->form-urlencoded parameters)))) (alist->form-urlencoded parameters))))
(define-values (body-port response-headers) (get-pure-port/headers request-url)) (define-values (body-port response-headers) (get-pure-port/headers request-url))

11
src/main.rkt
View File

@ -2,11 +2,6 @@
(module+ main (module+ main
(require "entrypoint.rkt") (require "entrypoint.rkt")
(require "signals.rkt") (start-service #:reloadable? (getenv "SITE_RELOADABLE")
(start-restart-signal-watcher) (make-entry-point 'request-handler "site.rkt")
;; (start-reloadable-service "site.rkt" (make-entry-point 'on-continuation-expiry "site.rkt")))
;; 'request-handler
;; 'on-continuation-expiry)
(require "site.rkt")
(start-service request-handler on-continuation-expiry)
)

211
src/packages.rkt
View File

@ -21,6 +21,7 @@
(require web-server/private/gzip) (require web-server/private/gzip)
(require (only-in web-server/private/util exn->string)) (require (only-in web-server/private/util exn->string))
(require net/url) (require net/url)
(require "reload.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -38,6 +39,11 @@
(define package-fetch-interval (* 300 1000)) ;; 300 seconds = 300,000 milliseconds = 5 minutes (define package-fetch-interval (* 300 1000)) ;; 300 seconds = 300,000 milliseconds = 5 minutes
(define base-bogus-timeout (* 5 1000)) ;; 5 seconds (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) (define (fetch-remote-packages)
(log-info "Fetching package list from ~a" package-index-url) (log-info "Fetching package list from ~a" package-index-url)
(define result (define result
@ -54,110 +60,127 @@
(define (tombstone? pkg) (define (tombstone? pkg)
(eq? pkg 'tombstone)) (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 (package-manager)
(define remote-packages (hash)) (with-handlers* ((exn:fail? (lambda (e)
(define all-tags* (set)) (log-error "*** PACKAGE MANAGER CRASHED ***\n~a"
(define local-packages (hash)) (exn->string e))
(define next-fetch-deadline 0) (sleep 5)
(define next-bogus-timeout base-bogus-timeout) (package-manager))))
(package-manager-main (package-manager-state (hash)
(set)
0
base-bogus-timeout))))
(define (asynchronously-fetch-remote-packages!) (define (refresh-packages raw-remote-packages state)
(thread (lambda () (define local-packages (package-manager-state-local-packages state))
(define raw-remote-packages (fetch-remote-packages)) (define remote-packages (for/hash (((package-name pkg) (in-hash raw-remote-packages)))
(if (hash? raw-remote-packages) (values package-name
(begin (set! next-bogus-timeout base-bogus-timeout) (hash-set pkg '_SEARCHABLE-TEXT_
(manager-rpc 'refresh-packages! raw-remote-packages)) (pkg->searchable-text pkg)))))
(begin (set! next-fetch-deadline (+ (current-inexact-milliseconds) (define all-package-names (set-union (list->set (hash-keys local-packages))
next-bogus-timeout)) (list->set (hash-keys remote-packages))))
(log-info "Will retry in ~a ms" next-bogus-timeout) (define new-local-packages
(set! next-bogus-timeout (min package-fetch-interval (for/fold ((acc (hash))) ((package-name all-package-names))
(* next-bogus-timeout 1.618))) (define local-pkg (hash-ref local-packages package-name (lambda () #f)))
(manager-rpc 'ping))))) (define remote-pkg (hash-ref remote-packages package-name (lambda () #f)))
(set! next-fetch-deadline (+ (current-inexact-milliseconds) package-fetch-interval))) (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) (define (rebuild-all-tags state)
(set! remote-packages (struct-copy package-manager-state state
(for/hash (((package-name pkg) (in-hash raw-remote-packages))) [all-tags
(values package-name (for/fold ((ts (set)))
(hash-set pkg '_SEARCHABLE-TEXT_ (pkg->searchable-text pkg))))) ((pkg (in-hash-values (package-manager-state-local-packages state))))
(define all-package-names (set-union (list->set (hash-keys local-packages)) (set-union ts (list->set (or (@ pkg tags) '()))))]))
(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!) (define (replace-package old-pkg new-pkg state)
(set! all-tags* (define local-packages (package-manager-state-local-packages state))
(for/fold ((ts (set))) ((pkg (in-hash-values local-packages))) (rebuild-all-tags
(set-union ts (list->set (or (@ pkg 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) (define (delete-package package-name state)
(set! local-packages (define local-packages (package-manager-state-local-packages state))
(hash-set (if old-pkg (if (hash-has-key? local-packages package-name)
(hash-remove local-packages (string->symbol (@ old-pkg name))) (struct-copy package-manager-state state
local-packages) [local-packages (hash-set local-packages package-name 'tombstone)])
(string->symbol (@ (or new-pkg old-pkg) name)) state))
(or new-pkg 'tombstone)))
(rebuild-all-tags!))
(define (delete-package! package-name) (define (package-manager-main state)
(when (hash-has-key? local-packages package-name) (match-define (package-manager-state local-packages
(set! local-packages (hash-set local-packages package-name 'tombstone)))) 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) (define package-manager-thread
(log-error "*** PACKAGE MANAGER CRASHED ***\n~a" (make-persistent-state 'package-manager-thread
(exn->string e)) (lambda () (thread package-manager))))
(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 (manager-rpc . request) (define (manager-rpc . request)
(define ch (make-channel)) (define ch (make-channel))
(thread-send package-manager-thread (cons ch request)) (thread-send (package-manager-thread) (cons ch request))
(channel-get ch)) (channel-get ch))
(define (all-package-names) (manager-rpc 'all-package-names)) (define (all-package-names) (manager-rpc 'all-package-names))

85
src/reload.rkt Normal file
View File

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

23
src/sessions.rkt
View File

@ -10,13 +10,14 @@
lookup-session) lookup-session)
(require "randomness.rkt") (require "randomness.rkt")
(require "reload.rkt")
(define current-session (make-parameter #f)) (define current-session (make-parameter #f))
(define session-lifetime (make-parameter (* 7 24 60 60 1000))) ;; one week in milliseconds (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 (current-email)
(define s (current-session)) (define s (current-session))
@ -24,15 +25,16 @@
(define (expire-sessions!) (define (expire-sessions!)
(define now (current-inexact-milliseconds)) (define now (current-inexact-milliseconds))
(for ((session-key (hash-keys sessions))) (define ss (sessions))
(define s (hash-ref sessions session-key (lambda () #f))) (for ((session-key (hash-keys ss)))
(define s (hash-ref ss session-key (lambda () #f)))
(when (and s (<= (session-expiry s) now)) (when (and s (<= (session-expiry s) now))
(hash-remove! sessions session-key)))) (hash-remove! ss session-key))))
(define (create-session! email password) (define (create-session! email password)
(expire-sessions!) (expire-sessions!)
(define session-key (bytes->string/utf-8 (random-bytes/base64 32))) (define session-key (bytes->string/utf-8 (random-bytes/base64 32)))
(hash-set! sessions (hash-set! (sessions)
session-key session-key
(session session-key (session session-key
(+ (current-inexact-milliseconds) (session-lifetime)) (+ (current-inexact-milliseconds) (session-lifetime))
@ -41,15 +43,16 @@
session-key) session-key)
(define (destroy-session! session-key) (define (destroy-session! session-key)
(hash-remove! sessions session-key)) (hash-remove! (sessions) session-key))
(define (lookup-session/touch! 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 (and s
(let ((s1 (struct-copy session s [expiry (+ (current-inexact-milliseconds) (let ((s1 (struct-copy session s [expiry (+ (current-inexact-milliseconds)
(session-lifetime))]))) (session-lifetime))])))
(hash-set! sessions session-key s1) (hash-set! (sessions) session-key s1)
s1))) s1)))
(define (lookup-session session-key) (define (lookup-session session-key)
(hash-ref sessions session-key (lambda () #f))) (hash-ref (sessions) session-key (lambda () #f)))

5
src/signals.rkt
View File

@ -4,6 +4,8 @@
(provide poll-signal (provide poll-signal
start-restart-signal-watcher) start-restart-signal-watcher)
(require "reload.rkt")
(define (poll-signal signal-file-name message handler) (define (poll-signal signal-file-name message handler)
(when (file-exists? signal-file-name) (when (file-exists? signal-file-name)
(log-info message) (log-info message)
@ -24,5 +26,8 @@
(poll-signal "../signals/.restart-required" (poll-signal "../signals/.restart-required"
"Restart signal received - attempting to restart" "Restart signal received - attempting to restart"
(lambda () (exit 0))) (lambda () (exit 0)))
(poll-signal "../signals/.reload"
"Reload signal received - attempting to reload code"
(lambda () (reload!)))
(sleep 0.5) (sleep 0.5)
(loop))))) (loop)))))

492
src/site.rkt
View File

@ -19,20 +19,26 @@
(define nav-index "Package Index") (define nav-index "Package Index")
(define nav-search "Search") (define nav-search "Search")
(bootstrap-navbar-header (define navbar-header
`(a ((href "http://www.racket-lang.org/")) `(a ((href "http://www.racket-lang.org/"))
(img ((src "/logo-and-text.png") (img ((src "/logo-and-text.png")
(height "60") (height "60")
(alt "Racket Package Index"))))) (alt "Racket Package Index")))))
(bootstrap-navigation `((,nav-index "/") (define navigation `((,nav-index "/")
(,nav-search "/search") (,nav-search "/search")
;; ((div ,(glyphicon 'download-alt) ;; ((div ,(glyphicon 'download-alt)
;; " Download") ;; " Download")
;; "http://download.racket-lang.org/") ;; "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 ...) (define-syntax-rule (authentication-wrap #:request request body ...)
(authentication-wrap* #f request (lambda () body ...))) (authentication-wrap* #f request (lambda () body ...)))
(define-syntax-rule (authentication-wrap/require-login #:request request body ...) (define-syntax-rule (authentication-wrap/require-login #:request request body ...)
(authentication-wrap* #t request (lambda () 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 (define clear-session-cookie (make-cookie COOKIE
"" ""
#:path "/" #:path "/"
@ -90,7 +96,8 @@
(if new-session-key (if new-session-key
(list (make-cookie COOKIE new-session-key #:path "/" #:secure? #t)) (list (make-cookie COOKIE new-session-key #:path "/" #:secure? #t))
(list clear-session-cookie)))) (list clear-session-cookie))))
(bootstrap-redirect (url->string (request-uri request))))) (with-site-config
(bootstrap-redirect (url->string (request-uri request))))))
(send/suspend/dispatch (send/suspend/dispatch
(lambda (embed-url) (lambda (embed-url)
@ -137,7 +144,7 @@
#:path "/" #:path "/"
#:secure? #t)) #:secure? #t))
(list)))) (list))))
(body))))))) (with-site-config (body))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -191,26 +198,27 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (login-page [error-message #f]) (define (login-page [error-message #f])
(send/suspend/dispatch (with-site-config
(lambda (embed-url) (send/suspend/dispatch
(bootstrap-response "Login" (lambda (embed-url)
`(form ((class "form-horizontal") (bootstrap-response "Login"
(method "post") `(form ((class "form-horizontal")
(action ,(embed-url process-login-credentials)) (method "post")
(role "form")) (action ,(embed-url process-login-credentials))
,(form-group 2 2 (label "email" "Email address") (role "form"))
0 5 (email-input "email")) ,(form-group 2 2 (label "email" "Email address")
,(form-group 2 2 (label "password" "Password:") 0 5 (email-input "email"))
0 5 (password-input "password")) ,(form-group 2 2 (label "password" "Password:")
,(form-group 4 5 0 5 (password-input "password"))
`(a ((href ,(embed-url (lambda (req) (register-page))))) ,(form-group 4 5
"Need to reset your password?")) `(a ((href ,(embed-url (lambda (req) (register-page)))))
,@(maybe-splice "Need to reset your password?"))
error-message ,@(maybe-splice
(form-group 4 5 error-message
`(div ((class "alert alert-danger")) (form-group 4 5
(p ,error-message)))) `(div ((class "alert alert-danger"))
,(form-group 4 5 (primary-button "Log in"))))))) (p ,error-message))))
,(form-group 4 5 (primary-button "Log in"))))))))
(define (authenticate-with-server! email password code) (define (authenticate-with-server! email password code)
(jsonp-rpc! #:sensitive? #t (jsonp-rpc! #:sensitive? #t
@ -236,41 +244,42 @@
(define (register-page #:email [email ""] (define (register-page #:email [email ""]
#:code [code ""] #:code [code ""]
#:error-message [error-message #f]) #:error-message [error-message #f])
(send/suspend/dispatch (with-site-config
(lambda (embed-url) (send/suspend/dispatch
(bootstrap-response "Register/Reset Account" (lambda (embed-url)
#:title-element "" (bootstrap-response "Register/Reset Account"
`(div #:title-element ""
(h1 "Got a registration or reset code?") `(div
(p "Great! Enter it below, with your chosen password, to log in.") (h1 "Got a registration or reset code?")
(form ((class "form-horizontal") (p "Great! Enter it below, with your chosen password, to log in.")
(method "post") (form ((class "form-horizontal")
(action ,(embed-url apply-account-code)) (method "post")
(role "form")) (action ,(embed-url apply-account-code))
,(form-group 2 2 (label "email" "Email address") (role "form"))
0 5 (email-input "email" email)) ,(form-group 2 2 (label "email" "Email address")
,(form-group 2 2 (label "code" "Code") 0 5 (email-input "email" email))
0 5 (text-input "code" code)) ,(form-group 2 2 (label "code" "Code")
,(form-group 2 2 (label "password" "Password") 0 5 (text-input "code" code))
0 5 (password-input "password")) ,(form-group 2 2 (label "password" "Password")
,(form-group 2 2 (label "password" "Confirm password") 0 5 (password-input "password"))
0 5 (password-input "confirm_password")) ,(form-group 2 2 (label "password" "Confirm password")
,@(maybe-splice 0 5 (password-input "confirm_password"))
error-message ,@(maybe-splice
(form-group 4 5 error-message
`(div ((class "alert alert-danger")) (form-group 4 5
(p ,error-message)))) `(div ((class "alert alert-danger"))
,(form-group 4 5 (primary-button "Continue")))) (p ,error-message))))
`(div ,(form-group 4 5 (primary-button "Continue"))))
(h1 "Need a code?") `(div
(p "Enter your email address below, and we'll send you one.") (h1 "Need a code?")
(form ((class "form-horizontal") (p "Enter your email address below, and we'll send you one.")
(method "post") (form ((class "form-horizontal")
(action ,(embed-url notify-of-emailing)) (method "post")
(role "form")) (action ,(embed-url notify-of-emailing))
,(form-group 2 2 (label "email" "Email address") (role "form"))
0 5 (email-input "email_for_code")) ,(form-group 2 2 (label "email" "Email address")
,(form-group 4 5 (primary-button "Email me a code")))))))) 0 5 (email-input "email_for_code"))
,(form-group 4 5 (primary-button "Email me a code")))))))))
(define (apply-account-code request) (define (apply-account-code request)
(define-form-bindings request (email code password confirm_password)) (define-form-bindings request (email code password confirm_password))
@ -304,16 +313,17 @@
(summarise-code-emailing "Account registration/reset code emailed" email_for_code)) (summarise-code-emailing "Account registration/reset code emailed" email_for_code))
(define (summarise-code-emailing reason email) (define (summarise-code-emailing reason email)
(send/suspend/dispatch (with-site-config
(lambda (embed-url) (send/suspend/dispatch
(bootstrap-response reason (lambda (embed-url)
`(p (bootstrap-response reason
"We've emailed an account registration/reset code to " `(p
(code ,email) ". Please check your email and then click " "We've emailed an account registration/reset code to "
"the button to continue:") (code ,email) ". Please check your email and then click "
`(a ((class "btn btn-primary") "the button to continue:")
(href ,(embed-url (lambda (req) (register-page))))) `(a ((class "btn btn-primary")
"Enter your code"))))) (href ,(embed-url (lambda (req) (register-page)))))
"Enter your code"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -445,9 +455,10 @@
(package-summary-table package-name-list))))) (package-summary-table package-name-list)))))
(define (logout-page request) (define (logout-page request)
(parameterize ((bootstrap-cookies (list clear-session-cookie))) (with-site-config
(when (current-session) (destroy-session! (session-key (current-session)))) (parameterize ((bootstrap-cookies (list clear-session-cookie)))
(bootstrap-redirect (named-url main-page)))) (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 ""]) (define (edit-package-page request [package-name-str ""])
(authentication-wrap/require-login (authentication-wrap/require-login
#:request request #:request request
@ -655,161 +664,163 @@
(cons default (remove default alist))) (cons default (remove default alist)))
(define (package-form error-message draft) (define (package-form error-message draft)
(send/suspend/dispatch (with-site-config
(lambda (embed-url) (send/suspend/dispatch
(lambda (embed-url)
(define (build-versions-table) (define (build-versions-table)
`(table ((class "package-versions")) `(table ((class "package-versions"))
(tr (th "Version") (tr (th "Version")
(th "Source")) (th "Source"))
,@(for/list ((v (put-default-first ,@(for/list ((v (put-default-first
(draft-package-versions draft)))) (draft-package-versions draft))))
(match-define (list version source) v) (match-define (list version source) v)
(define (control-name c) (format "version__~a__~a" version c)) (define (control-name c) (format "version__~a__~a" version c))
(define (group-name c) (format "version__~a__~a__group" version c)) (define (group-name c) (format "version__~a__~a__group" version c))
(define (textfield name label-text value [placeholder ""]) (define (textfield name label-text value [placeholder ""])
(row #:id (group-name name) (row #:id (group-name name)
0 3 0 3
(and label-text (label (control-name name) label-text)) (and label-text (label (control-name name) label-text))
0 (if label-text 9 12) 0 (if label-text 9 12)
(text-input (control-name name) value #:placeholder placeholder))) (text-input (control-name name) value #:placeholder placeholder)))
(define-values (source-type simple-url g-host g-user g-project g-branch) (define-values (source-type simple-url g-host g-user g-project g-branch)
(match source (match source
[(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?" [(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?"
(list _ u p _ b)) (list _ u p _ b))
(values "github" "" "github.com" u p (if (equal? b "master") "" (or b #f)))] (values "github" "" "github.com" u p (if (equal? b "master") "" (or b #f)))]
[(pregexp #px"git://([^/]*)/([^/]*)/([^/]*)(/([^/]*)/?)?" [(pregexp #px"git://([^/]*)/([^/]*)/([^/]*)(/([^/]*)/?)?"
(list _ h u p _ b)) (list _ h u p _ b))
(values "git" "" h u p (if (equal? b "master") "" (or b "")))] (values "git" "" h u p (if (equal? b "master") "" (or b "")))]
[_ [_
(values "simple" source "" "" "" "")])) (values "simple" source "" "" "" "")]))
`(tr `(tr
(td ,version (td ,version
,@(maybe-splice ,@(maybe-splice
(not (equal? version "default")) (not (equal? version "default"))
" " " "
`(button ((class "btn btn-danger btn-xs") `(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") (type "submit")
(name "action") (name "action")
(value ,(control-name "delete"))) (value "add_version"))
,(glyphicon 'trash)))) ,(glyphicon 'plus-sign) " Add new version"))))
(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")) (parameterize ((bootstrap-page-scripts '("/editpackage.js")))
(div ((class "form-inline")) (define old-name (draft-package-old-name draft))
,(text-input "new_version" #:placeholder "x.y.z") (define has-old-name? (not (equal? old-name "")))
" " (bootstrap-response (if has-old-name?
(button ((class "btn btn-success btn-xs") (format "Editing package ~a" old-name)
(type "submit") "Creating a new package")
(name "action") (if error-message
(value "add_version")) `(div ((class "alert alert-danger"))
,(glyphicon 'plus-sign) " Add new version")))) ,(glyphicon 'exclamation-sign) " " ,error-message)
)) "")
`(form ((id "edit-package-form")
(parameterize ((bootstrap-page-scripts '("/editpackage.js"))) (method "post")
(define old-name (draft-package-old-name draft)) (action ,(embed-url (update-draft draft)))
(define has-old-name? (not (equal? old-name ""))) (role "form"))
(bootstrap-response (if has-old-name? (div ((class "container")) ;; TODO: remove??
(format "Editing package ~a" old-name) (div ((class "row"))
"Creating a new package") (div ((class "form-group col-sm-6"))
(if error-message ,(label "name" "Package Name")
`(div ((class "alert alert-danger")) ,(text-input "name" (~a (draft-package-name draft))))
,(glyphicon 'exclamation-sign) " " ,error-message) (div ((class "form-group col-sm-6"))
"") ,(label "tags" "Package Tags (space-separated)")
`(form ((id "edit-package-form") ,(text-input "tags" (string-join
(method "post") (draft-package-tags draft)))))
(action ,(embed-url (update-draft draft))) (div ((class "row"))
(role "form")) (div ((class "form-group col-sm-6"))
(div ((class "container")) ;; TODO: remove?? ,(label "description" "Package Description")
(div ((class "row")) (textarea ((class "form-control")
(div ((class "form-group col-sm-6")) (name "description")
,(label "name" "Package Name") (id "description"))
,(text-input "name" (~a (draft-package-name draft)))) ,(draft-package-description draft)))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
,(label "tags" "Package Tags (space-separated)") ,(label "authors"
,(text-input "tags" (string-join "Author email addresses (one per line)")
(draft-package-tags draft))))) (textarea ((class "form-control")
(div ((class "row")) (name "authors")
(div ((class "form-group col-sm-6")) (id "authors"))
,(label "description" "Package Description") ,(string-join (draft-package-authors draft)
(textarea ((class "form-control") "\n"))))
(name "description") (div ((class "row"))
(id "description")) (div ((class "form-group col-sm-12"))
,(draft-package-description draft))) ,(label #f "Package Versions & Sources")
(div ((class "form-group col-sm-6")) ,(build-versions-table)))
,(label "authors" (div ((class "row"))
"Author email addresses (one per line)") (div ((class "form-group col-sm-12"))
(textarea ((class "form-control") ,@(maybe-splice
(name "authors") has-old-name?
(id "authors")) `(a ((class "btn btn-danger pull-right")
,(string-join (draft-package-authors draft) (href ,(embed-url
"\n")))) (confirm-package-deletion old-name))))
(div ((class "row")) ,(glyphicon 'trash) " Delete package")
(div ((class "form-group col-sm-12")) " ")
,(label #f "Package Versions & Sources") (button ((type "submit")
,(build-versions-table))) (class "btn btn-primary")
(div ((class "row")) (name "action")
(div ((class "form-group col-sm-12")) (value "save_changes"))
,@(maybe-splice ,(glyphicon 'save) " Save changes")
has-old-name? ,@(maybe-splice
`(a ((class "btn btn-danger pull-right") has-old-name?
(href ,(embed-url " "
(confirm-package-deletion old-name)))) `(a ((class "btn btn-default")
,(glyphicon 'trash) " Delete package") (href ,(named-url package-page old-name)))
" ") "Cancel changes and return to package page"))))))
(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) (define ((confirm-package-deletion package-name-str) request)
(send/suspend (with-site-config
(lambda (k-url) (send/suspend
(bootstrap-response "Confirm Package Deletion" (lambda (k-url)
`(div ((class "confirm-package-deletion")) (bootstrap-response "Confirm Package Deletion"
(h2 ,(format "Delete ~a?" package-name-str)) `(div ((class "confirm-package-deletion"))
(p "This cannot be undone.") (h2 ,(format "Delete ~a?" package-name-str))
(a ((class "btn btn-default") (p "This cannot be undone.")
(href ,k-url)) (a ((class "btn btn-default")
"Confirm deletion"))))) (href ,k-url))
(jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str))) "Confirm deletion")))))
(delete-package! (string->symbol package-name-str)) (jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str)))
(bootstrap-redirect (named-url main-page))) (delete-package! (string->symbol package-name-str))
(bootstrap-redirect (named-url main-page))))
(define ((update-draft draft0) request) (define ((update-draft draft0) request)
(define draft (read-draft-form draft0 (request-bindings request))) (define draft (read-draft-form draft0 (request-bindings request)))
@ -817,7 +828,8 @@
(match action (match action
["save_changes" ["save_changes"
(if (save-draft! draft) (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." (package-form "Save failed."
;; ^ TODO: This is the worst error message. ;; ^ TODO: This is the worst error message.
;; Right up there with "parse error". ;; Right up there with "parse error".