Reloadable code.
This commit is contained in:
Tony Garnock-Jones
parent
5a717489d2
commit
8458130d0e
2
Makefile
2
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 {} \;
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
11
src/main.rkt
11
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")))
|
||||
|
|
|
|||
211
src/packages.rkt
211
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))
|
||||
|
|
|
|||
85
src/reload.rkt
Normal file
85
src/reload.rkt
Normal 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)))
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
492
src/site.rkt
492
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".
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user