From 9629f12b7b4f60f97858bd331cdbfec1a69eeb73 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 8 Nov 2014 18:12:04 -0500 Subject: [PATCH] Version 1 --- TODO | 1 + src/bootstrap.rkt | 18 +- src/entrypoint.rkt | 19 + src/main.rkt | 802 +++++++++++++++++++++++++++++++----------- src/packages.rkt | 169 +++++++-- src/sessions.rkt | 9 +- static/editpackage.js | 79 +++-- static/style.css | 30 +- 8 files changed, 868 insertions(+), 259 deletions(-) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 0000000..9519d4a --- /dev/null +++ b/TODO @@ -0,0 +1 @@ +Documentation/help text on the edit package page? diff --git a/src/bootstrap.rkt b/src/bootstrap.rkt index f340955..a29e2ee 100644 --- a/src/bootstrap.rkt +++ b/src/bootstrap.rkt @@ -3,6 +3,7 @@ (provide bootstrap-project-name bootstrap-project-link + bootstrap-navbar-header bootstrap-navigation bootstrap-active-navigation bootstrap-navbar-extension @@ -10,7 +11,8 @@ bootstrap-page-scripts bootstrap-cookies - bootstrap-response + bootstrap-response + bootstrap-redirect bootstrap-radio bootstrap-fieldset bootstrap-button) @@ -21,6 +23,7 @@ (define bootstrap-project-name (make-parameter "Project")) (define bootstrap-project-link (make-parameter "/")) +(define bootstrap-navbar-header (make-parameter #f)) (define bootstrap-navigation (make-parameter '(("Home" "/")))) (define bootstrap-active-navigation (make-parameter #f)) (define bootstrap-navbar-extension (make-parameter '())) @@ -53,8 +56,9 @@ (nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation")) (div ((class "container")) (div ((class "navbar-header")) - (a ((class "navbar-brand") (href ,(bootstrap-project-link))) - ,(bootstrap-project-name))) + ,(or (bootstrap-navbar-header) + `(a ((class "navbar-brand") (href ,(bootstrap-project-link))) + ,(bootstrap-project-name)))) (div ((id "navbar") (class "collapse navbar-collapse")) (ul ((class "nav navbar-nav")) ,@(for/list ((n (bootstrap-navigation))) @@ -74,6 +78,14 @@ ,@(for/list ((script (bootstrap-page-scripts))) `(script ((type "text/javascript") (src ,script)))))))) +(define (bootstrap-redirect url + #:permanent? [permanent? #f] + #:headers [headers '()]) + (redirect-to url + (if permanent? permanently temporarily) + #:headers (append (map cookie->header (bootstrap-cookies)) + headers))) + ;; String String XExpr ... -> XExpr ;; Constructs Bootstrap boilerplate for a radio button. (define (bootstrap-radio #:checked [checked #f] field-name field-value . label-contents) diff --git a/src/entrypoint.rkt b/src/entrypoint.rkt index a1d1202..b86ede0 100644 --- a/src/entrypoint.rkt +++ b/src/entrypoint.rkt @@ -3,10 +3,25 @@ (provide start-service) (require web-server/servlet-env) +(require web-server/managers/lru) +(require web-server/http/request-structs) +(require net/url) (require "signals.rkt") +(require "bootstrap.rkt") + +(define (strip-parameters u) + (struct-copy url u + [path (map (lambda (element) + (struct-copy path/param element + [param '()])) + (url-path u))])) + +(define (default-expiry-handler request) + (bootstrap-redirect (url->string (strip-parameters (request-uri request))))) (define (start-service #:port [port 8443] #:ssl? [ssl? #t] + #:on-continuation-expiry [on-continuation-expiry default-expiry-handler] request-handler-function) (start-restart-signal-watcher) (serve/servlet request-handler-function @@ -14,6 +29,10 @@ #:quit? #f #:listen-ip #f #:port port + #:manager (make-threshold-LRU-manager + on-continuation-expiry + ;; This value is copied from web-server/servlet-env.rkt: + (* 128 1024 1024)) #:extra-files-paths (list (build-path (current-directory) "../static")) #:ssl? ssl? diff --git a/src/main.rkt b/src/main.rkt index d76ae23..bb3c5cd 100644 --- a/src/main.rkt +++ b/src/main.rkt @@ -7,6 +7,7 @@ (require racket/port) (require racket/string) (require net/uri-codec) +(require json) (require web-server/servlet) (require web-server/http/id-cookie) (require web-server/http/cookie-parse) @@ -16,22 +17,20 @@ (require "sessions.rkt") (define nav-index "Package Index") -(define nav-docs "Documentation") +(define nav-search "Search") -(bootstrap-project-name - `(a ((class "four columns logo") - (href "http://www.racket-lang.org/")) +(bootstrap-navbar-header + `(a ((href "http://www.racket-lang.org/")) (img ((src "/logo-and-text.png") (height "50") (alt "Racket Package Index"))))) -(bootstrap-active-navigation nav-index) (bootstrap-navigation `((,nav-index "/") - ("Documentation" "http://docs.racket-lang.org/") - ("Blog" "http://blog.racket-lang.org/") - ((div (span ((class "glyphicon glyphicon-download-alt"))) - " Download") - "http://download.racket-lang.org/"))) + (,nav-search "/search") + ;; ((div (span ((class "glyphicon glyphicon-download-alt"))) + ;; " Download") + ;; "http://download.racket-lang.org/") + )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -41,6 +40,8 @@ [("search") search-page] [("package" (string-arg)) package-page] [("package" (string-arg) "edit") edit-package-page] + [("create") edit-package-page] + [("logout") logout-page] )) (module+ main @@ -49,70 +50,127 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-syntax-rule (authentication-wrap #:request request body ...) - (authentication-wrap* request (lambda () body ...))) - +(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 current-session (make-parameter #f)) (define (current-email) (define s (current-session)) (and s (session-email s))) -(define (authentication-wrap* request body) - (define original-session-cookie - (findf (lambda (c) (equal? (client-cookie-name c) COOKIE)) - (request-cookies request))) - (define original-session-key - (and original-session-cookie (client-cookie-value original-session-cookie))) - (log-info "Session key from cookie: ~a" original-session-key) - (let redo ((session-key original-session-key - )) - (define session (lookup-session/touch! session-key)) - (log-info "session: ~a" session) +(define clear-session-cookie (make-cookie COOKIE + "" + #:path "/" + #:expires "Thu, 01 Jan 1970 00:00:00 GMT")) + +(define (authentication-wrap* require-login? request body) + (define original-session-cookies + (filter (lambda (c) (equal? (client-cookie-name c) COOKIE)) + (request-cookies request))) + (define original-session-keys + (map client-cookie-value original-session-cookies)) + ;; (log-info "Session keys from cookie: ~a" original-session-keys) + (let redo ((session-keys original-session-keys)) + (define session (for/or ((k session-keys)) (lookup-session/touch! k))) + ;; (log-info "session: ~a" session) (send/suspend/dispatch (lambda (embed-url) - (parameterize ((bootstrap-navbar-extension - (cond - [(not session) - `((a ((class "btn btn-default navbar-btn navbar-right") - (href ,(embed-url (lambda (req) (redo (register-page)))))) - "Register") - (a ((class "btn btn-success navbar-btn navbar-right") - (href ,(embed-url (lambda (req) (redo (login-page)))))) - "Sign in"))] - [else - `((ul ((class "nav navbar-nav navbar-right")) - (li ((class "dropdown")) - (a ((class "dropdown-toggle") - (data-toggle "dropdown")) - ,(session-email session) - " " - (span ((class "caret")))) - (ul ((class "dropdown-menu") (role "menu")) - (li "foo") - (li "bar")))))])) - (current-session session) - (bootstrap-cookies - (if session - (list (make-cookie COOKIE session-key - #:secure? #t)) - (list (make-cookie COOKIE "" - #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))))) - (body)))))) + (if (and require-login? (not session)) + (redo (list (login-page))) + (parameterize ((bootstrap-navbar-extension + (cond + [(not session) + `((a ((class "btn btn-default navbar-btn navbar-right") + (href ,(embed-url (lambda (req) (redo (list (register-page))))))) + "Register") + (a ((class "btn btn-success navbar-btn navbar-right") + (href ,(embed-url (lambda (req) (redo (list (login-page))))))) + "Sign in"))] + [else + `((ul ((class "nav navbar-nav navbar-right")) + (li ((class "dropdown")) + (a ((class "dropdown-toggle") + (data-toggle "dropdown")) + ,(session-email session) + " " + (span ((class "caret")))) + (ul ((class "dropdown-menu") (role "menu")) + (li (a ((href ,(named-url edit-package-page))) + (span ((class "glyphicon glyphicon-plus-sign"))) + " New package")) + (li (a ((href ,(tags-page-url + (list + (format "author:~a" + (session-email session)))))) + (span ((class "glyphicon glyphicon-user"))) + " My packages")) + (li ((class "divider")) + (li (a ((href ,(named-url logout-page))) + (span ((class "glyphicon glyphicon-log-out"))) + " Log out")))))))])) + (current-session session) + (bootstrap-cookies + (if session + (list (make-cookie COOKIE + (session-key session) + #:path "/" + #:secure? #t)) + (list)))) + (body))))))) + +(define (jsonp-rpc! #:sensitive? [sensitive? #f] + #:include-credentials? [include-credentials? #t] + site-relative-url + original-parameters) + (define s (current-session)) + (if sensitive? + (log-info "jsonp-rpc: sensitive request ~a" site-relative-url) + (log-info "jsonp-rpc: request ~a params ~a~a" + site-relative-url + original-parameters + (if include-credentials? + (if s + " +creds" + " +creds(missing)") + ""))) + (define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds))))) + (define callback-label (format "callback~a" stamp)) + (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp)) + (let* ((parameters original-parameters) + (parameters (if (and include-credentials? s) + (append (list (cons 'email (session-email s)) + (cons 'passwd (session-password s))) + parameters) + parameters)) + (parameters (cons (cons 'callback callback-label) parameters))) + (define request-url + (string->url + (format "https://pkgd.racket-lang.org~a?~a" + site-relative-url + (alist->form-urlencoded parameters)))) + (define-values (body-port response-headers) (get-pure-port/headers request-url)) + (define raw-response (port->string body-port)) + (match-define (pregexp extraction-expr (list _ json)) raw-response) + (define reply (string->jsexpr json)) + (unless sensitive? (log-info "jsonp-rpc: reply ~a" reply)) + reply)) (define (authenticate-with-server! email password code) - (define auth-url - (string->url - (format "https://pkgd.racket-lang.org/jsonp/authenticate?~a" - (alist->form-urlencoded (list (cons 'callback "x") - (cons 'email email) - (cons 'passwd password) - (cons 'code code)))))) - (define-values (body-port response-headers) (get-pure-port/headers auth-url)) - (match-define (pregexp #px"^x\\((.*)\\);$" (list _ json)) (port->string body-port)) - (log-info "JSON: ~a" json) - json) + (jsonp-rpc! #:sensitive? #t + #:include-credentials? #f + "/jsonp/authenticate" + (list (cons 'email email) + (cons 'passwd password) + (cons 'code code)))) (define (login-page [error-message #f]) (send/suspend/dispatch @@ -143,23 +201,32 @@ (div ((class "form-group")) (div ((class "col-sm-offset-4 col-sm-5")) (a ((href ,(embed-url (lambda (req) (register-page))))) - "Need to reset your password?") - (div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (button ((type "submit") - (class "btn btn-primary")) - "Log in")))) - )))))) + "Need to reset your password?"))) + ,@(maybe-splice + error-message + `(div ((class "form-group")) + (div ((class "col-sm-offset-4 col-sm-5")) + (div ((class "alert alert-danger")) + (p ,error-message))))) + (div ((class "form-group")) + (div ((class "col-sm-offset-4 col-sm-5")) + (button ((type "submit") + (class "btn btn-primary")) + "Log in")))) + )))) (define (process-login-credentials request) (define-form-bindings request (email password)) - (match (authenticate-with-server! email password "") - ["wrong-code" - (login-page "Something went awry; please try again.")] - [(or "emailed" #f) - (summarise-code-emailing "Incorrect password, or nonexistent user." email)] - [else - (create-session! email password)])) + (if (or (equal? (string-trim email) "") + (equal? (string-trim password) "")) + (login-page "Please enter your email address and password.") + (match (authenticate-with-server! email password "") + ["wrong-code" + (login-page "Something went awry; please try again.")] + [(or "emailed" #f) + (summarise-code-emailing "Incorrect password, or nonexistent user." email)] + [else + (create-session! email password)]))) (define (register-page #:email [email ""] #:code [code ""] @@ -336,9 +403,12 @@ `(ul ((class "list-inline taglinks")) ,@(for/list ((tag (or tags '()))) `(li ,(tag-link tag))))) (define (utc->string utc) - (string-append (date->string (seconds->date utc #f) #t) " (UTC)")) + (if utc + (string-append (date->string (seconds->date utc #f) #t) " (UTC)") + "N/A")) (define (package-summary-table package-names) + (define now (/ (current-inexact-milliseconds) 1000)) `(table ((class "packages sortable")) (tr @@ -354,7 +424,9 @@ `(tr (td (h2 ,(package-link package-name)) ,(authors-list (@ pkg authors)) - ;; recently-updated? + ,@(maybe-splice + (< (- now (or (@ pkg last-updated) 0)) recent-seconds) + `(span ((class "label label-info")) "Updated")) ) (td (p ,(@ pkg description)) ,@(maybe-splice @@ -388,28 +460,47 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (main-page request) - (authentication-wrap - #:request request - (bootstrap-response "Racket Package Index" - #:title-element "" - `(div ((class "jumbotron")) - (h1 "Racket Package Index") - (p "These are the packages available via the " - (a ((href "docs.racket-lang.org/pkg/getting-started.html")) - "Racket package system") ".") - (p "Simply run " (kbd "raco pkg install " (var "package-name")) - " to install a package.") - (form ((role "form") - (action ,(named-url search-page))) - (div ((class "form-group")) - (input ((class "form-control") - (type "text") - (placeholder "Search packages") - (name "q") - (value "") - (id "q")))) - )) - (package-summary-table (package-search "" '((main-distribution #f))))))) + (parameterize ((bootstrap-active-navigation nav-index)) + (define package-name-list (package-search "" '((main-distribution #f)))) + (authentication-wrap + #:request request + (bootstrap-response "Racket Package Index" + #:title-element "" + `(div ((class "jumbotron")) + (h1 "Racket Package Index") + (p "These are the packages available via the " + (a ((href "docs.racket-lang.org/pkg/getting-started.html")) + "Racket package system") ".") + (p "Simply run " (kbd "raco pkg install " (var "package-name")) + " to install a package.") + (p ((class "text-center")) + (span ((class "package-count")) ,(~a (length package-name-list))) + " packages in the index.") + (form ((role "form") + (action ,(named-url search-page))) + (div ((class "form-group")) + (input ((class "form-control") + (type "text") + (placeholder "Search packages") + (name "q") + (value "") + (id "q")))) + )) + (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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (build-status str label-type glyphicon) + `(p ((class "build-status")) + "Build status: " + (span ((class ,(format "label label-~a" label-type))) + (span ((class ,(format "glyphicon glyphicon-~a" glyphicon)))) + " " ,str))) (define (package-page request package-name-str) (authentication-wrap @@ -427,6 +518,16 @@ `(div ((class "jumbotron")) (h1 ,(~a package-name)) (p ,(@ pkg description)) + ,(cond + [(@ pkg build failure-log) + (build-status "failed" "danger" "fire")] + [(and (@ pkg build success-log) + (@ pkg build dep-failure-log)) + (build-status "problems" "warning" "question-sign")] + [(@ pkg build success-log) + (build-status "ok" "success" "ok")] + [else + ""]) (div ,@(let ((docs (or (@ pkg build docs) '()))) (match docs [(list) @@ -469,6 +570,15 @@ " Edit this package")) )) + (if (@ pkg _LOCALLY_MODIFIED_) + `(div ((class "alert alert-warning") + (role "alert")) + (span ((class "glyphicon glyphicon-exclamation-sign"))) + " This package has been modified since the package index was last rebuilt." + " The next index refresh is scheduled for " + ,(utc->string (/ (next-fetch-deadline) 1000)) ".") + "") + (if (@ pkg checksum-error) `(div ((class "alert alert-danger") (role "alert")) @@ -488,7 +598,7 @@ (tr (th "Last updated") (td ,(utc->string (@ pkg last-updated)))) (tr (th "Ring") - (td ,(~a (@ pkg ring)))) + (td ,(~a (or (@ pkg ring) "N/A")))) (tr (th "Conflicts") (td ,(package-links (@ pkg conflicts)))) (tr (th "Dependencies") @@ -514,7 +624,7 @@ ))) (tr (th "Modules") (td (ul ((class "module-list")) - ,@(for/list ((mod (@ pkg modules))) + ,@(for/list ((mod (or (@ pkg modules) '()))) (match-define (list kind path) mod) `(li ((class ,kind)) ,path))))) ,@(let* ((vs (or (@ pkg versions) (hash))) @@ -547,26 +657,27 @@ (struct draft-package (old-name name description authors tags versions) #:transparent) -(define (edit-package-page request package-name-str) - (authentication-wrap +(define (edit-package-page request [package-name-str ""]) + (authentication-wrap/require-login #:request request (define package-name (string->symbol package-name-str)) (define pkg (package-detail package-name)) (cond [(and pkg (not (member (current-email) (or (@ pkg authors) '())))) ;; Not ours. Show it instead. - (package-page request package-name-str)] + (bootstrap-redirect (named-url package-page package-name-str))] [(not pkg) ;; Doesn't exist. - (package-form (draft-package "" - package-name - "" - '() - '() - '(("default" ""))))] + (package-form #f (draft-package "" + package-name-str + "" + (list (current-email)) + '() + `(("default" ,default-empty-source-url))))] [else - (package-form (draft-package package-name - package-name + (package-form #f + (draft-package package-name-str + package-name-str (@ pkg description) (@ pkg authors) (@ pkg tags) @@ -578,96 +689,155 @@ ,@(maybe-splice (equal? source-type value) '(selected "selected"))) ,label)) -(define (package-form draft) +(define (put-default-first alist) + (define default (assoc "default" alist)) + (cons default (remove default alist))) + +(define (package-form error-message draft) (send/suspend/dispatch (lambda (embed-url) (define (build-versions-table) - `(table + `(table ((class "package-versions")) (tr (th "Version") (th "Source")) - ,@(for/list ((v (draft-package-versions draft))) + ,@(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 value [placeholder ""]) - `(div ((class "form-group")) - (label ((for ,(control-name name))) ,label) - (input ((class "form-control") - (type "text") - (name ,(control-name name)) - (id ,(control-name name)) - (placeholder ,placeholder) - (value ,value))))) + `(div ((id ,(group-name name)) + (class "row")) + ,@(maybe-splice + label + `(div ((class "col-sm-3")) + (label ((class "control-label") + (for ,(control-name name))) + ,label))) + (div ((class ,(if label "col-sm-9" "col-sm-12"))) + (input ((class "form-control") + (type "text") + (name ,(control-name name)) + (id ,(control-name name)) + (placeholder ,placeholder) + (value ,value)))))) (define-values (source-type simple-url g-host g-user g-project g-branch) (match source - [(pregexp #px"github://github\\.com/([^/]+)/([^/]+)(/([^/]+)/?)?" + [(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://([^/]+)/([^/]+)/([^/]+)(/([^/]+)/?)?" + [(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) - (td (div ((class "form-group")) - (label ((for ,(control-name "type"))) "Source 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"))) - ,(textfield "simple_url" "Source URL" simple-url) - ,(textfield "g_host" "Git Repository Host" g-host) - ,(textfield "g_user" "Git Repository User" g-user) - ,(textfield "g_project" "Git Repository Project" g-project) - ,(textfield "g_branch" "Git Repository Branch" g-branch "master") + (td ,version ,@(maybe-splice (not (equal? version "default")) - `(button ((type "submit") - (name ,(control-name "delete"))) - (span ((class "glyphicon glyphicon-delete"))) - " Delete version"))))))) + " " + `(button ((class "btn btn-danger btn-xs") + (type "submit") + (name "action") + (value ,(control-name "delete"))) + (span ((class "glyphicon glyphicon-trash")))))) + (td (div ((class "row")) + (div ((class "col-sm-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")))) + (div ((id ,(group-name "fields")) + (class "col-sm-9")) + (div ((id ,(group-name "urlpreview")) + (class "row")) + (div ((class "col-sm-3")) + (label ((class "control-label")) "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")) + (input ((class "form-control") + (type "text") + (name "new_version") + (id "new_version") + (placeholder "x.y.z") + (value ""))) + " " + (button ((class "btn btn-success btn-xs") + (type "submit") + (name "action") + (value "add_version")) + (span ((class "glyphicon glyphicon-plus-sign"))) + " Add new version")))) + )) (parameterize ((bootstrap-page-scripts '("/editpackage.js"))) - (bootstrap-response (format "Editing package ~a" (draft-package-old-name draft)) - `(form ((method "post") - (action "TODO") + (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")) + (span ((class "glyphicon glyphicon-exclamation-sign"))) + " " ,error-message) + "") + `(form ((id "edit-package-form") + (method "post") + (action ,(embed-url (update-draft draft))) (role "form")) - (div ((class "container")) + (div ((class "container")) ;; TODO: remove?? (div ((class "row")) (div ((class "form-group col-sm-6")) - (label ((for "name")) "Package Name") + (label ((for "name") + (class "control-label")) + "Package Name") (input ((class "form-control") (type "text") (name "name") (id "name") (value ,(~a (draft-package-name draft)))))) (div ((class "form-group col-sm-6")) - (label ((for "tags")) "Package Tags (space-separated)") + (label ((for "tags") + (class "control-label")) + "Package Tags (space-separated)") (input ((class "form-control") (type "text") - (tags "tags") + (name "tags") (id "tags") (value ,(string-join (draft-package-tags draft))))))) (div ((class "row")) (div ((class "form-group col-sm-6")) - (label ((for "description")) "Package Description") + (label ((for "description") + (class "control-label")) + "Package Description") (textarea ((class "form-control") (name "description") (id "description")) ,(draft-package-description draft))) (div ((class "form-group col-sm-6")) - (label ((for "authors")) + (label ((for "authors") + (class "control-label")) "Author email addresses (one per line)") (textarea ((class "form-control") (name "authors") @@ -676,58 +846,280 @@ "\n")))) (div ((class "row")) (div ((class "form-group col-sm-12")) - (label "Package Versions & Sources") + (label ((class "control-label")) + "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)))) + (span ((class "glyphicon glyphicon-trash"))) + " Delete package") + " ") (button ((type "submit") (class "btn btn-primary") - (name "save_changes")) + (name "action") + (value "save_changes")) (span ((class "glyphicon glyphicon-save"))) - " Save changes"))))) + " 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))) + +(define ((update-draft draft0) request) + (define draft (read-draft-form draft0 (request-bindings request))) + (define-form-bindings request (action new_version)) + (match action + ["save_changes" + (if (save-draft! draft) + (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". + draft))] + ["add_version" + (if (assoc new_version (draft-package-versions draft)) + (package-form (format "Could not add version ~a, as it already exists." new_version) + draft) + (package-form #f (struct-copy draft-package draft + [versions (cons (list new_version default-empty-source-url) + (draft-package-versions draft))])))] + [(regexp #px"^version__(.*)__delete$" (list _ version)) + (package-form #f (struct-copy draft-package draft + [versions (filter (lambda (v) + (not (equal? (car v) version))) + (draft-package-versions draft))]))])) + +(define (read-draft-form draft bindings) + (define (g key d) + (cond [(assq key bindings) => cdr] + [else d])) + (define (read-version-source version) + (define (vg name d) + (g (string->symbol (format "version__~a__~a" version name)) d)) + (define type (vg 'type "simple")) + (define simple_url (vg 'simple_url "")) + (define g_host (vg 'g_host "")) + (define g_user (vg 'g_user "")) + (define g_project (vg 'g_project "")) + (define g_branch0 (vg 'g_branch "")) + (define g_branch (if (equal? g_branch0 "") "master" g_branch0)) + (match type + ["github" (format "github://github.com/~a/~a/~a" g_user g_project g_branch)] + ["git" (format "git://~a/~a/~a/~a" g_host g_user g_project g_branch)] + ["simple" simple_url])) + (struct-copy draft-package draft + [name (g 'name (draft-package-old-name draft))] + [description (g 'description "")] + [authors (string-split (g 'authors ""))] + [tags (string-split (g 'tags ""))] + [versions (for/list ((old (draft-package-versions draft))) + (match-define (list version _) old) + (list version + (read-version-source version)))])) + +(define (added-and-removed old new) + (define old-set (list->set (or old '()))) + (define new-set (list->set new)) + (values (set->list (set-subtract new-set old-set)) + (set->list (set-subtract old-set new-set)))) + +(define (save-draft! draft) + (match-define (draft-package old-name name description authors tags versions/default) draft) + (define default-version (assoc "default" versions/default)) + (define source (cadr default-version)) + (define versions (remove default-version versions/default)) + + (define old-pkg (package-detail (string->symbol old-name))) + + (define-values (added-tags removed-tags) + (added-and-removed (@ old-pkg tags) tags)) + (define-values (added-authors removed-authors) + (added-and-removed (or (@ old-pkg authors) (list (current-email))) authors)) + + (define old-versions-map (or (@ old-pkg versions) (hash))) + (define changed-versions + (for/fold ((acc '())) ((v versions)) + (match-define (list version-str new-source) v) + (define version-sym (string->symbol version-str)) + (define old-source (@ (@ref old-versions-map version-sym) source)) + (if (equal? old-source new-source) + acc + (cons v acc)))) + (define removed-versions + (for/list ((k (in-hash-keys old-versions-map)) + #:when (not (assoc (symbol->string k) versions/default))) ;; NB versions/default ! + (symbol->string k))) + + ;; name, description, and default source are updateable via /jsonp/package/modify. + ;; tags are added and removed via /jsonp/package/tag/add and .../del. + ;; authors are added and removed via /jsonp/package/author/add and .../del. + ;; versions other than default are added and removed via /jsonp/package/version/add and .../del. + (and (or (equal? old-name name) + ;; Don't let renames stomp on existing packages + (not (package-detail (string->symbol name)))) + (jsonp-rpc! "/jsonp/package/modify" `((pkg . ,old-name) + (name . ,name) + (description . ,description) + (source . ,source))) + (andmap (lambda (t) (jsonp-rpc! "/jsonp/package/tag/add" `((pkg . ,name) (tag . ,t)))) + added-tags) + (andmap (lambda (t) (jsonp-rpc! "/jsonp/package/tag/del" `((pkg . ,name) (tag . ,t)))) + removed-tags) + (andmap (lambda (a) (jsonp-rpc! "/jsonp/package/author/add" `((pkg . ,name) (author . ,a)))) + added-authors) + (andmap (lambda (a) (jsonp-rpc! "/jsonp/package/author/del" `((pkg . ,name) (author . ,a)))) + removed-authors) + (andmap (lambda (e) (jsonp-rpc! "/jsonp/package/version/add" `((pkg . ,name) + (version . ,(car e)) + (source . ,(cadr e))))) + changed-versions) + (andmap (lambda (v) (jsonp-rpc! "/jsonp/package/version/del" `((pkg . ,name) + (version . ,v)))) + removed-versions) + + (let* ((new-pkg (or old-pkg (hash))) + (new-pkg (hash-set new-pkg 'name name)) + (new-pkg (hash-set new-pkg 'description description)) + (new-pkg (hash-set new-pkg 'author (string-join authors))) + (new-pkg (hash-set new-pkg 'authors authors)) + (new-pkg (hash-set new-pkg 'tags tags)) + (new-pkg (hash-set new-pkg 'versions (friendly-versions versions/default))) + (new-pkg (hash-set new-pkg 'source source)) + (new-pkg (hash-set new-pkg 'search-terms (compute-search-terms new-pkg))) + (new-pkg (hash-set new-pkg '_LOCALLY_MODIFIED_ #t))) + (replace-package! old-pkg new-pkg) + #t))) + +;; Based on (and copied from) the analogous code in meta/pkg-index/official/static.rkt +(define (compute-search-terms ht) + (let* ([st (hasheq)] + [st (for/fold ([st st]) + ([t (in-list (hash-ref ht 'tags (lambda () '())))]) + (hash-set st (string->symbol t) #t))] + [st (hash-set + st + (string->symbol + (format "ring:~a" (hash-ref ht 'ring (lambda () 2)))) #t)] + [st (for/fold ([st st]) + ([a (in-list (string-split (hash-ref ht 'author (lambda () ""))))]) + (hash-set + st (string->symbol (format "author:~a" a)) #t))] + [st (if (null? (hash-ref ht 'tags (lambda () '()))) + (hash-set st ':no-tag: #t) + st)] + [st (if (hash-ref ht 'checksum-error #f) + (hash-set st ':error: #t) + st)] + [st (if (equal? "" (hash-ref ht 'description "")) + (hash-set st ':no-desc: #t) + st)] + [st (if (null? (hash-ref ht 'conflicts (lambda () '()))) + st + (hash-set st ':conflicts: #t))]) + st)) + +(define (friendly-versions draft-versions) + (for/hash ((v draft-versions)) + (match-define (list version source) v) + (values (string->symbol version) + (hash 'checksum "" + 'source source + 'source_url (package-url->useful-url source))))) + +;; Copied from meta/pkg-index/official/static.rkt +(define (package-url->useful-url pkg-url-str) + (define pkg-url + (string->url pkg-url-str)) + (match (url-scheme pkg-url) + ["github" + (match (url-path pkg-url) + [(list* user repo branch path) + (url->string + (struct-copy + url pkg-url + [scheme "http"] + [path (list* user repo (path/param "tree" '()) branch path)]))] + [_ + pkg-url-str])] + ["git" + (match (url-path pkg-url) + ;; xxx make this more robust + [(list user repo) + (url->string + (struct-copy + url pkg-url + [scheme "http"] + [path (list user repo (path/param "tree" '()) + (path/param "master" '()))]))] + [_ + pkg-url-str])] + [_ + pkg-url-str])) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (search-page request) - (authentication-wrap - #:request request - (define-form-bindings request ([search-text q ""] - [tags-input tags ""])) - (define tags (for/list ((t (string-split tags-input))) - (match t - [(pregexp #px"!(.*)" (list _ tag)) (list (string->symbol tag) #f)] - [tag (list (string->symbol tag) #t)]))) - (bootstrap-response "Search Racket Package Index" - `(form ((class "form-horizontal") - (role "form")) - (div ((class "form-group")) - (label ((class "col-sm-2 control-label") - (for "q")) "Search terms") - (div ((class "col-sm-10")) - (input ((class "form-control") - (type "text") - (placeholder "Enter free-form text to match here") - (name "q") - (value ,search-text) - (id "q"))))) - (div ((class "form-group")) - (label ((class "col-sm-2 control-label") - (for "tags")) "Tags") - (div ((class "col-sm-10")) - (input ((class "form-control") - (type "text") - (placeholder "tag1 tag2 tag3 ...") - (name "tags") - (value ,tags-input) - (id "tags"))))) - (div ((class "form-group")) - (div ((class "col-sm-offset-2 col-sm-10")) - (button ((type "submit") - (class "btn btn-primary")) - (span ((class "glyphicon glyphicon-search"))) - " Search"))) - (div ((class "search-results")) - ,@(maybe-splice - (or (pair? tags) (not (equal? search-text ""))) - (package-summary-table (package-search search-text tags)))))))) + (parameterize ((bootstrap-active-navigation nav-search)) + (authentication-wrap + #:request request + (define-form-bindings request ([search-text q ""] + [tags-input tags ""])) + (define tags (for/list ((t (string-split tags-input))) + (match t + [(pregexp #px"!(.*)" (list _ tag)) (list (string->symbol tag) #f)] + [tag (list (string->symbol tag) #t)]))) + (bootstrap-response "Search Racket Package Index" + `(form ((class "form-horizontal") + (role "form")) + (div ((class "form-group")) + (label ((class "col-sm-2 control-label") + (for "q")) "Search terms") + (div ((class "col-sm-10")) + (input ((class "form-control") + (type "text") + (placeholder "Enter free-form text to match here") + (name "q") + (value ,search-text) + (id "q"))))) + (div ((class "form-group")) + (label ((class "col-sm-2 control-label") + (for "tags")) "Tags") + (div ((class "col-sm-10")) + (input ((class "form-control") + (type "text") + (placeholder "tag1 tag2 tag3 ...") + (name "tags") + (value ,tags-input) + (id "tags"))))) + (div ((class "form-group")) + (div ((class "col-sm-offset-2 col-sm-10")) + (button ((type "submit") + (class "btn btn-primary")) + (span ((class "glyphicon glyphicon-search"))) + " Search"))) + (div ((class "search-results")) + ,@(maybe-splice + (or (pair? tags) (not (equal? search-text ""))) + (package-summary-table (package-search search-text tags))))))))) diff --git a/src/packages.rkt b/src/packages.rkt index d2c6cb2..ddb2971 100644 --- a/src/packages.rkt +++ b/src/packages.rkt @@ -7,15 +7,20 @@ sorted-package-names package-detail package-search - refresh-packages!) + replace-package! + delete-package! + refresh-packages! + next-fetch-deadline) (require json) (require racket/set) (require racket/match) -(require racket/file) +(require racket/port) (require racket/string) (require racket/list) (require web-server/private/gzip) +(require (only-in web-server/private/util exn->string)) +(require net/url) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -29,14 +34,139 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define packages (hash)) -(define all-tags* (set)) +(define package-index-url "http://pkgs.racket-lang.org/pkgs-all.json.gz") +(define package-fetch-interval (* 300 1000)) ;; 300 seconds = 300,000 milliseconds = 5 minutes +(define base-bogus-timeout (* 5 1000)) ;; 5 seconds -(define (all-package-names) - (hash-keys packages)) +(define (fetch-remote-packages) + (log-info "Fetching package list from ~a" package-index-url) + (define result + (with-handlers ((exn:fail? (lambda (e) #f))) + (define response-bytes (port->bytes (get-pure-port (string->url package-index-url)))) + (define decompressed (gunzip/bytes response-bytes)) + (define decoded (bytes->jsexpr decompressed)) + decoded)) + (if (hash? result) + (log-info "Fetched package list containing ~a packages." (hash-count result)) + (log-info "Fetched bogus package list")) + result) -(define (all-tags) - all-tags*) +(define (tombstone? pkg) + (eq? pkg 'tombstone)) + +(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) + + (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) + (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!) + (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) + (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) + (when (hash-has-key? local-packages package-name) + (set! local-packages (hash-set local-packages package-name 'tombstone)))) + + (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 (manager-rpc . request) + (define ch (make-channel)) + (thread-send package-manager-thread (cons ch request)) + (channel-get ch)) + +(define (all-package-names) (manager-rpc 'all-package-names)) +(define (all-tags) (manager-rpc 'all-tags)) +(define (package-detail package-name) (manager-rpc 'package-detail package-name)) +(define (replace-package! old-pkg new-pkg) (manager-rpc 'replace-package! old-pkg new-pkg)) +(define (delete-package! package-name) (manager-rpc 'delete-package! package-name)) +(define (refresh-packages!) (manager-rpc 'refresh-packages!)) +(define (next-fetch-deadline) (manager-rpc 'next-fetch-deadline)) (define (sort-package-names names) (sort names (lambda (a b) (stringstring a) (symbol->string b))))) @@ -44,9 +174,6 @@ (define (sorted-package-names) (sort-package-names (all-package-names))) -(define (package-detail package-name) - (hash-ref packages package-name (lambda () #f))) - (define (pkg->searchable-text pkg) (string-join (flatten (list (or (@ pkg authors) '()) (map (match-lambda @@ -63,10 +190,12 @@ (or (@ pkg build docs) '())))))) (define ((package-text-matches? pkg) re) - (regexp-match? re (@ pkg _SEARCHABLE-TEXT_))) + (and (not (tombstone? pkg)) + (regexp-match? re (@ pkg _SEARCHABLE-TEXT_)))) (define (package-search text tags) (define res (map (lambda (r) (pregexp (format "(?i:~a)" r))) (string-split text))) + (define packages (manager-rpc 'packages)) (sort-package-names (filter (lambda (package-name) (define pkg (hash-ref packages package-name)) @@ -75,18 +204,6 @@ (for/fold ((ps packages)) ((tag-spec tags)) (match-define (list tag-name include?) tag-spec) (for/hash (((package-name pkg) (in-hash ps)) - #:when ((if include? values not) (@ref (@ pkg search-terms) tag-name))) + #:when (and (not (tombstone? pkg)) + ((if include? values not) (@ref (@ pkg search-terms) tag-name)))) (values package-name pkg))))))) - -(define (refresh-packages!) - (set! packages - (for/hash (((package-name pkg) - (in-hash (bytes->jsexpr (gunzip/bytes (file->bytes "../pkgs-all.json.gz")))))) - (values package-name - (hash-set pkg '_SEARCHABLE-TEXT_ (pkg->searchable-text pkg))))) - (set! all-tags* - (for/fold ((ts (set))) ((pkg (in-hash-values packages))) - (set-union ts (list->set (or (@ pkg tags) '())))))) - -(refresh-packages!) - diff --git a/src/sessions.rkt b/src/sessions.rkt index ec8bc4b..1ce9a36 100644 --- a/src/sessions.rkt +++ b/src/sessions.rkt @@ -3,6 +3,7 @@ (provide session-lifetime (struct-out session) create-session! + destroy-session! lookup-session/touch! lookup-session) @@ -10,7 +11,7 @@ (define session-lifetime (make-parameter (* 7 24 60 60 1000))) ;; one week in milliseconds -(struct session (expiry email password) #:transparent) +(struct session (key expiry email password) #:transparent) (define sessions (make-hash)) @@ -26,11 +27,15 @@ (define session-key (bytes->string/utf-8 (random-bytes/base64 32))) (hash-set! sessions session-key - (session (+ (current-inexact-milliseconds) (session-lifetime)) + (session session-key + (+ (current-inexact-milliseconds) (session-lifetime)) email password)) session-key) +(define (destroy-session! session-key) + (hash-remove! sessions session-key)) + (define (lookup-session/touch! session-key) (define s (hash-ref sessions session-key (lambda () #f))) (and s diff --git a/static/editpackage.js b/static/editpackage.js index bca0407..9d5e43b 100644 --- a/static/editpackage.js +++ b/static/editpackage.js @@ -1,48 +1,83 @@ -function preenSourceTypes() { - $(".package-version-source-type").each(function (index, e) { - preenSourceType(e); - }); +function control(e, name) { + // Use getElementById here because there are dots (!) in the ID + // strings, and if we were to use jquery, it would interpret those + // as class separators. + return $(document.getElementById("version__" + e.dataset.packageversion + "__" + name)); } +// Update control visibility for a particular package version source +// control group when its type selector changes value. +// function preenSourceType(e) { - function controlId(name) { - return "#version__" + e.dataset.packageversion + "__" + name; - } function showhide1(n, v) { - var c = $(controlId(n)); + var c = control(e, n + "__group"); if (v) { c.show(); } else { c.hide(); } + return control(e, n).val(); } function showhide(s, gh, gu, gp, gb) { - showhide1("simple_url", s); - showhide1("g_host", gh); - showhide1("g_user", gu); - showhide1("g_project", gp); - showhide1("g_branch", gb); + return [showhide1("simple_url", s), + showhide1("g_host", gh), + showhide1("g_user", gu), + showhide1("g_project", gp), + showhide1("g_branch", gb)]; } - console.log(e.dataset.packageversion); + var pieces; + var previewUrl; + var previewGroup = control(e, "urlpreview__group"); + var previewInput = control(e, "urlpreview"); switch (e.value) { case "github": - showhide(false, false, true, true, true); + previewGroup.show(); + pieces = showhide(false, false, true, true, true); + previewUrl = "github://github.com/" + pieces[2] + "/" + pieces[3] + + (pieces[4] ? "/" + pieces[4] : ""); break; case "git": - showhide(false, true, true, true, true); + previewGroup.show(); + pieces = showhide(false, true, true, true, true); + previewUrl = "git://" + pieces[1] + "/" + pieces[2] + "/" + pieces[3] + + (pieces[4] ? "/" + pieces[4] : ""); break; case "simple": default: - showhide(true, false, false, false, false); + previewGroup.hide(); + pieces = showhide(true, false, false, false, false); + previewUrl = pieces[0]; break; } + previewInput.html("").append(document.createTextNode(previewUrl)); } $(document).ready(function () { - $(".package-version-source-type").each(function (index, e) { - $(e).change(function () { - preenSourceType(e); - }); + // Stop the enter key from submitting the form using a random submit + // button (there is no sensible default to choose; or rather, the + // default varies with location). + // + // We could come back to this later and make enter do the + // contextually-appropriate thing, perhaps, but I think it's not + // much of a win at the moment. + // + $('#edit-package-form').bind("keyup keypress", function(e) { + if (e.which == 13 && document.activeElement.tagName !== "TEXTAREA") { + e.preventDefault(); + return false; + } + }); + + // Start monitoring package version source type selectors for + // changes, and do the initial cleanup of the form fields. + // + $(".package-version-source-type").each(function (index, e) { + var preenE = function () { preenSourceType(e); }; + $(e).change(preenE); + var names = ['simple_url', 'g_host', 'g_user', 'g_project', 'g_branch']; + for (var i = 0; i < names.length; i++) { + control(e, names[i]).change(preenE).keyup(preenE); + } + preenSourceType(e); }); - preenSourceTypes(); }); diff --git a/static/style.css b/static/style.css index b86690d..0930eb2 100644 --- a/static/style.css +++ b/static/style.css @@ -4,6 +4,7 @@ body { padding-top: 50px; + padding-bottom: 50px; font-family: "Open Sans"; font-weight: 400; color: #1e1e1e; @@ -18,7 +19,7 @@ body { .doctags-label { font-weight: bold; } -table.packages, table.package-details { +table.packages, table.package-details, table.package-versions { width: 100%; } @@ -45,3 +46,30 @@ ul.module-list { } .search-results table { margin-top: 3em; } + +input#new_version { + width: 6em; +} + +.confirm-package-deletion { + background-color: red; + padding: 2em; + display: block; + margin-left: auto; + margin-right: auto; + width: 50%; + text-align: center; + color: white; + border: solid yellow 1em; +} +.confirm-package-deletion h2 { + margin: 0; +} + +.package-count { + font-size: 120%; +} + +.jumbotron .build-status { + font-size: 100%; +}