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

Version 1

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-08 18:12:04 -05:00
parent d3e0a061d9
commit 9629f12b7b
8 changed files with 868 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO Normal file
View File

@ -0,0 +1 @@
Documentation/help text on the edit package page?

18
src/bootstrap.rkt
View File

@ -3,6 +3,7 @@
(provide bootstrap-project-name (provide bootstrap-project-name
bootstrap-project-link bootstrap-project-link
bootstrap-navbar-header
bootstrap-navigation bootstrap-navigation
bootstrap-active-navigation bootstrap-active-navigation
bootstrap-navbar-extension bootstrap-navbar-extension
@ -10,7 +11,8 @@
bootstrap-page-scripts bootstrap-page-scripts
bootstrap-cookies bootstrap-cookies
bootstrap-response bootstrap-response
bootstrap-redirect
bootstrap-radio bootstrap-radio
bootstrap-fieldset bootstrap-fieldset
bootstrap-button) bootstrap-button)
@ -21,6 +23,7 @@
(define bootstrap-project-name (make-parameter "Project")) (define bootstrap-project-name (make-parameter "Project"))
(define bootstrap-project-link (make-parameter "/")) (define bootstrap-project-link (make-parameter "/"))
(define bootstrap-navbar-header (make-parameter #f))
(define bootstrap-navigation (make-parameter '(("Home" "/")))) (define bootstrap-navigation (make-parameter '(("Home" "/"))))
(define bootstrap-active-navigation (make-parameter #f)) (define bootstrap-active-navigation (make-parameter #f))
(define bootstrap-navbar-extension (make-parameter '())) (define bootstrap-navbar-extension (make-parameter '()))
@ -53,8 +56,9 @@
(nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation")) (nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation"))
(div ((class "container")) (div ((class "container"))
(div ((class "navbar-header")) (div ((class "navbar-header"))
(a ((class "navbar-brand") (href ,(bootstrap-project-link))) ,(or (bootstrap-navbar-header)
,(bootstrap-project-name))) `(a ((class "navbar-brand") (href ,(bootstrap-project-link)))
,(bootstrap-project-name))))
(div ((id "navbar") (class "collapse navbar-collapse")) (div ((id "navbar") (class "collapse navbar-collapse"))
(ul ((class "nav navbar-nav")) (ul ((class "nav navbar-nav"))
,@(for/list ((n (bootstrap-navigation))) ,@(for/list ((n (bootstrap-navigation)))
@ -74,6 +78,14 @@
,@(for/list ((script (bootstrap-page-scripts))) ,@(for/list ((script (bootstrap-page-scripts)))
`(script ((type "text/javascript") (src ,script)))))))) `(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 ;; String String XExpr ... -> XExpr
;; Constructs Bootstrap boilerplate for a radio button. ;; Constructs Bootstrap boilerplate for a radio button.
(define (bootstrap-radio #:checked [checked #f] field-name field-value . label-contents) (define (bootstrap-radio #:checked [checked #f] field-name field-value . label-contents)

19
src/entrypoint.rkt
View File

@ -3,10 +3,25 @@
(provide start-service) (provide start-service)
(require web-server/servlet-env) (require web-server/servlet-env)
(require web-server/managers/lru)
(require web-server/http/request-structs)
(require net/url)
(require "signals.rkt") (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] (define (start-service #:port [port 8443]
#:ssl? [ssl? #t] #:ssl? [ssl? #t]
#:on-continuation-expiry [on-continuation-expiry default-expiry-handler]
request-handler-function) request-handler-function)
(start-restart-signal-watcher) (start-restart-signal-watcher)
(serve/servlet request-handler-function (serve/servlet request-handler-function
@ -14,6 +29,10 @@
#:quit? #f #:quit? #f
#:listen-ip #f #:listen-ip #f
#:port port #: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) #:extra-files-paths (list (build-path (current-directory)
"../static")) "../static"))
#:ssl? ssl? #:ssl? ssl?

802
src/main.rkt
View File

@ -7,6 +7,7 @@
(require racket/port) (require racket/port)
(require racket/string) (require racket/string)
(require net/uri-codec) (require net/uri-codec)
(require json)
(require web-server/servlet) (require web-server/servlet)
(require web-server/http/id-cookie) (require web-server/http/id-cookie)
(require web-server/http/cookie-parse) (require web-server/http/cookie-parse)
@ -16,22 +17,20 @@
(require "sessions.rkt") (require "sessions.rkt")
(define nav-index "Package Index") (define nav-index "Package Index")
(define nav-docs "Documentation") (define nav-search "Search")
(bootstrap-project-name (bootstrap-navbar-header
`(a ((class "four columns logo") `(a ((href "http://www.racket-lang.org/"))
(href "http://www.racket-lang.org/"))
(img ((src "/logo-and-text.png") (img ((src "/logo-and-text.png")
(height "50") (height "50")
(alt "Racket Package Index"))))) (alt "Racket Package Index")))))
(bootstrap-active-navigation nav-index)
(bootstrap-navigation `((,nav-index "/") (bootstrap-navigation `((,nav-index "/")
("Documentation" "http://docs.racket-lang.org/") (,nav-search "/search")
("Blog" "http://blog.racket-lang.org/") ;; ((div (span ((class "glyphicon glyphicon-download-alt")))
((div (span ((class "glyphicon glyphicon-download-alt"))) ;; " Download")
" Download") ;; "http://download.racket-lang.org/")
"http://download.racket-lang.org/"))) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -41,6 +40,8 @@
[("search") search-page] [("search") search-page]
[("package" (string-arg)) package-page] [("package" (string-arg)) package-page]
[("package" (string-arg) "edit") edit-package-page] [("package" (string-arg) "edit") edit-package-page]
[("create") edit-package-page]
[("logout") logout-page]
)) ))
(module+ main (module+ main
@ -49,70 +50,127 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax-rule (authentication-wrap #:request request body ...) (define default-empty-source-url "git://github.com//")
(authentication-wrap* request (lambda () body ...)))
(define COOKIE "pltsession") (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-session (make-parameter #f))
(define (current-email) (define (current-email)
(define s (current-session)) (define s (current-session))
(and s (session-email s))) (and s (session-email s)))
(define (authentication-wrap* request body) (define clear-session-cookie (make-cookie COOKIE
(define original-session-cookie ""
(findf (lambda (c) (equal? (client-cookie-name c) COOKIE)) #:path "/"
(request-cookies request))) #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))
(define original-session-key
(and original-session-cookie (client-cookie-value original-session-cookie))) (define (authentication-wrap* require-login? request body)
(log-info "Session key from cookie: ~a" original-session-key) (define original-session-cookies
(let redo ((session-key original-session-key (filter (lambda (c) (equal? (client-cookie-name c) COOKIE))
)) (request-cookies request)))
(define session (lookup-session/touch! session-key)) (define original-session-keys
(log-info "session: ~a" session) (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 (send/suspend/dispatch
(lambda (embed-url) (lambda (embed-url)
(parameterize ((bootstrap-navbar-extension (if (and require-login? (not session))
(cond (redo (list (login-page)))
[(not session) (parameterize ((bootstrap-navbar-extension
`((a ((class "btn btn-default navbar-btn navbar-right") (cond
(href ,(embed-url (lambda (req) (redo (register-page)))))) [(not session)
"Register") `((a ((class "btn btn-default navbar-btn navbar-right")
(a ((class "btn btn-success navbar-btn navbar-right") (href ,(embed-url (lambda (req) (redo (list (register-page)))))))
(href ,(embed-url (lambda (req) (redo (login-page)))))) "Register")
"Sign in"))] (a ((class "btn btn-success navbar-btn navbar-right")
[else (href ,(embed-url (lambda (req) (redo (list (login-page)))))))
`((ul ((class "nav navbar-nav navbar-right")) "Sign in"))]
(li ((class "dropdown")) [else
(a ((class "dropdown-toggle") `((ul ((class "nav navbar-nav navbar-right"))
(data-toggle "dropdown")) (li ((class "dropdown"))
,(session-email session) (a ((class "dropdown-toggle")
" " (data-toggle "dropdown"))
(span ((class "caret")))) ,(session-email session)
(ul ((class "dropdown-menu") (role "menu")) " "
(li "foo") (span ((class "caret"))))
(li "bar")))))])) (ul ((class "dropdown-menu") (role "menu"))
(current-session session) (li (a ((href ,(named-url edit-package-page)))
(bootstrap-cookies (span ((class "glyphicon glyphicon-plus-sign")))
(if session " New package"))
(list (make-cookie COOKIE session-key (li (a ((href ,(tags-page-url
#:secure? #t)) (list
(list (make-cookie COOKIE "" (format "author:~a"
#:expires "Thu, 01 Jan 1970 00:00:00 GMT"))))) (session-email session))))))
(body)))))) (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 (authenticate-with-server! email password code)
(define auth-url (jsonp-rpc! #:sensitive? #t
(string->url #:include-credentials? #f
(format "https://pkgd.racket-lang.org/jsonp/authenticate?~a" "/jsonp/authenticate"
(alist->form-urlencoded (list (cons 'callback "x") (list (cons 'email email)
(cons 'email email) (cons 'passwd password)
(cons 'passwd password) (cons 'code code))))
(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)
(define (login-page [error-message #f]) (define (login-page [error-message #f])
(send/suspend/dispatch (send/suspend/dispatch
@ -143,23 +201,32 @@
(div ((class "form-group")) (div ((class "form-group"))
(div ((class "col-sm-offset-4 col-sm-5")) (div ((class "col-sm-offset-4 col-sm-5"))
(a ((href ,(embed-url (lambda (req) (register-page))))) (a ((href ,(embed-url (lambda (req) (register-page)))))
"Need to reset your password?") "Need to reset your password?")))
(div ((class "form-group")) ,@(maybe-splice
(div ((class "col-sm-offset-4 col-sm-5")) error-message
(button ((type "submit") `(div ((class "form-group"))
(class "btn btn-primary")) (div ((class "col-sm-offset-4 col-sm-5"))
"Log in")))) (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 (process-login-credentials request)
(define-form-bindings request (email password)) (define-form-bindings request (email password))
(match (authenticate-with-server! email password "") (if (or (equal? (string-trim email) "")
["wrong-code" (equal? (string-trim password) ""))
(login-page "Something went awry; please try again.")] (login-page "Please enter your email address and password.")
[(or "emailed" #f) (match (authenticate-with-server! email password "")
(summarise-code-emailing "Incorrect password, or nonexistent user." email)] ["wrong-code"
[else (login-page "Something went awry; please try again.")]
(create-session! email password)])) [(or "emailed" #f)
(summarise-code-emailing "Incorrect password, or nonexistent user." email)]
[else
(create-session! email password)])))
(define (register-page #:email [email ""] (define (register-page #:email [email ""]
#:code [code ""] #:code [code ""]
@ -336,9 +403,12 @@
`(ul ((class "list-inline taglinks")) ,@(for/list ((tag (or tags '()))) `(li ,(tag-link tag))))) `(ul ((class "list-inline taglinks")) ,@(for/list ((tag (or tags '()))) `(li ,(tag-link tag)))))
(define (utc->string utc) (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 (package-summary-table package-names)
(define now (/ (current-inexact-milliseconds) 1000))
`(table `(table
((class "packages sortable")) ((class "packages sortable"))
(tr (tr
@ -354,7 +424,9 @@
`(tr `(tr
(td (h2 ,(package-link package-name)) (td (h2 ,(package-link package-name))
,(authors-list (@ pkg authors)) ,(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)) (td (p ,(@ pkg description))
,@(maybe-splice ,@(maybe-splice
@ -388,28 +460,47 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (main-page request) (define (main-page request)
(authentication-wrap (parameterize ((bootstrap-active-navigation nav-index))
#:request request (define package-name-list (package-search "" '((main-distribution #f))))
(bootstrap-response "Racket Package Index" (authentication-wrap
#:title-element "" #:request request
`(div ((class "jumbotron")) (bootstrap-response "Racket Package Index"
(h1 "Racket Package Index") #:title-element ""
(p "These are the packages available via the " `(div ((class "jumbotron"))
(a ((href "docs.racket-lang.org/pkg/getting-started.html")) (h1 "Racket Package Index")
"Racket package system") ".") (p "These are the packages available via the "
(p "Simply run " (kbd "raco pkg install " (var "package-name")) (a ((href "docs.racket-lang.org/pkg/getting-started.html"))
" to install a package.") "Racket package system") ".")
(form ((role "form") (p "Simply run " (kbd "raco pkg install " (var "package-name"))
(action ,(named-url search-page))) " to install a package.")
(div ((class "form-group")) (p ((class "text-center"))
(input ((class "form-control") (span ((class "package-count")) ,(~a (length package-name-list)))
(type "text") " packages in the index.")
(placeholder "Search packages") (form ((role "form")
(name "q") (action ,(named-url search-page)))
(value "") (div ((class "form-group"))
(id "q")))) (input ((class "form-control")
)) (type "text")
(package-summary-table (package-search "" '((main-distribution #f))))))) (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) (define (package-page request package-name-str)
(authentication-wrap (authentication-wrap
@ -427,6 +518,16 @@
`(div ((class "jumbotron")) `(div ((class "jumbotron"))
(h1 ,(~a package-name)) (h1 ,(~a package-name))
(p ,(@ pkg description)) (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) '()))) (div ,@(let ((docs (or (@ pkg build docs) '())))
(match docs (match docs
[(list) [(list)
@ -469,6 +570,15 @@
" Edit this package")) " 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) (if (@ pkg checksum-error)
`(div ((class "alert alert-danger") `(div ((class "alert alert-danger")
(role "alert")) (role "alert"))
@ -488,7 +598,7 @@
(tr (th "Last updated") (tr (th "Last updated")
(td ,(utc->string (@ pkg last-updated)))) (td ,(utc->string (@ pkg last-updated))))
(tr (th "Ring") (tr (th "Ring")
(td ,(~a (@ pkg ring)))) (td ,(~a (or (@ pkg ring) "N/A"))))
(tr (th "Conflicts") (tr (th "Conflicts")
(td ,(package-links (@ pkg conflicts)))) (td ,(package-links (@ pkg conflicts))))
(tr (th "Dependencies") (tr (th "Dependencies")
@ -514,7 +624,7 @@
))) )))
(tr (th "Modules") (tr (th "Modules")
(td (ul ((class "module-list")) (td (ul ((class "module-list"))
,@(for/list ((mod (@ pkg modules))) ,@(for/list ((mod (or (@ pkg modules) '())))
(match-define (list kind path) mod) (match-define (list kind path) mod)
`(li ((class ,kind)) ,path))))) `(li ((class ,kind)) ,path)))))
,@(let* ((vs (or (@ pkg versions) (hash))) ,@(let* ((vs (or (@ pkg versions) (hash)))
@ -547,26 +657,27 @@
(struct draft-package (old-name name description authors tags versions) #:transparent) (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 (authentication-wrap/require-login
#:request request #:request request
(define package-name (string->symbol package-name-str)) (define package-name (string->symbol package-name-str))
(define pkg (package-detail package-name)) (define pkg (package-detail package-name))
(cond (cond
[(and pkg (not (member (current-email) (or (@ pkg authors) '())))) [(and pkg (not (member (current-email) (or (@ pkg authors) '()))))
;; Not ours. Show it instead. ;; Not ours. Show it instead.
(package-page request package-name-str)] (bootstrap-redirect (named-url package-page package-name-str))]
[(not pkg) [(not pkg)
;; Doesn't exist. ;; Doesn't exist.
(package-form (draft-package "" (package-form #f (draft-package ""
package-name package-name-str
"" ""
'() (list (current-email))
'() '()
'(("default" ""))))] `(("default" ,default-empty-source-url))))]
[else [else
(package-form (draft-package package-name (package-form #f
package-name (draft-package package-name-str
package-name-str
(@ pkg description) (@ pkg description)
(@ pkg authors) (@ pkg authors)
(@ pkg tags) (@ pkg tags)
@ -578,96 +689,155 @@
,@(maybe-splice (equal? source-type value) '(selected "selected"))) ,@(maybe-splice (equal? source-type value) '(selected "selected")))
,label)) ,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 (send/suspend/dispatch
(lambda (embed-url) (lambda (embed-url)
(define (build-versions-table) (define (build-versions-table)
`(table `(table ((class "package-versions"))
(tr (th "Version") (tr (th "Version")
(th "Source")) (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) (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 (textfield name label value [placeholder ""]) (define (textfield name label value [placeholder ""])
`(div ((class "form-group")) `(div ((id ,(group-name name))
(label ((for ,(control-name name))) ,label) (class "row"))
(input ((class "form-control") ,@(maybe-splice
(type "text") label
(name ,(control-name name)) `(div ((class "col-sm-3"))
(id ,(control-name name)) (label ((class "control-label")
(placeholder ,placeholder) (for ,(control-name name)))
(value ,value))))) ,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) (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
(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")
,@(maybe-splice ,@(maybe-splice
(not (equal? version "default")) (not (equal? version "default"))
`(button ((type "submit") " "
(name ,(control-name "delete"))) `(button ((class "btn btn-danger btn-xs")
(span ((class "glyphicon glyphicon-delete"))) (type "submit")
" Delete version"))))))) (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"))) (parameterize ((bootstrap-page-scripts '("/editpackage.js")))
(bootstrap-response (format "Editing package ~a" (draft-package-old-name draft)) (define old-name (draft-package-old-name draft))
`(form ((method "post") (define has-old-name? (not (equal? old-name "")))
(action "TODO") (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")) (role "form"))
(div ((class "container")) (div ((class "container")) ;; TODO: remove??
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
(label ((for "name")) "Package Name") (label ((for "name")
(class "control-label"))
"Package Name")
(input ((class "form-control") (input ((class "form-control")
(type "text") (type "text")
(name "name") (name "name")
(id "name") (id "name")
(value ,(~a (draft-package-name draft)))))) (value ,(~a (draft-package-name draft))))))
(div ((class "form-group col-sm-6")) (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") (input ((class "form-control")
(type "text") (type "text")
(tags "tags") (name "tags")
(id "tags") (id "tags")
(value ,(string-join (value ,(string-join
(draft-package-tags draft))))))) (draft-package-tags draft)))))))
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
(label ((for "description")) "Package Description") (label ((for "description")
(class "control-label"))
"Package Description")
(textarea ((class "form-control") (textarea ((class "form-control")
(name "description") (name "description")
(id "description")) (id "description"))
,(draft-package-description draft))) ,(draft-package-description draft)))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
(label ((for "authors")) (label ((for "authors")
(class "control-label"))
"Author email addresses (one per line)") "Author email addresses (one per line)")
(textarea ((class "form-control") (textarea ((class "form-control")
(name "authors") (name "authors")
@ -676,58 +846,280 @@
"\n")))) "\n"))))
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-12")) (div ((class "form-group col-sm-12"))
(label "Package Versions & Sources") (label ((class "control-label"))
"Package Versions & Sources")
,(build-versions-table))) ,(build-versions-table)))
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-12")) (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") (button ((type "submit")
(class "btn btn-primary") (class "btn btn-primary")
(name "save_changes")) (name "action")
(value "save_changes"))
(span ((class "glyphicon glyphicon-save"))) (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) (define (search-page request)
(authentication-wrap (parameterize ((bootstrap-active-navigation nav-search))
#:request request (authentication-wrap
(define-form-bindings request ([search-text q ""] #:request request
[tags-input tags ""])) (define-form-bindings request ([search-text q ""]
(define tags (for/list ((t (string-split tags-input))) [tags-input tags ""]))
(match t (define tags (for/list ((t (string-split tags-input)))
[(pregexp #px"!(.*)" (list _ tag)) (list (string->symbol tag) #f)] (match t
[tag (list (string->symbol tag) #t)]))) [(pregexp #px"!(.*)" (list _ tag)) (list (string->symbol tag) #f)]
(bootstrap-response "Search Racket Package Index" [tag (list (string->symbol tag) #t)])))
`(form ((class "form-horizontal") (bootstrap-response "Search Racket Package Index"
(role "form")) `(form ((class "form-horizontal")
(div ((class "form-group")) (role "form"))
(label ((class "col-sm-2 control-label") (div ((class "form-group"))
(for "q")) "Search terms") (label ((class "col-sm-2 control-label")
(div ((class "col-sm-10")) (for "q")) "Search terms")
(input ((class "form-control") (div ((class "col-sm-10"))
(type "text") (input ((class "form-control")
(placeholder "Enter free-form text to match here") (type "text")
(name "q") (placeholder "Enter free-form text to match here")
(value ,search-text) (name "q")
(id "q"))))) (value ,search-text)
(div ((class "form-group")) (id "q")))))
(label ((class "col-sm-2 control-label") (div ((class "form-group"))
(for "tags")) "Tags") (label ((class "col-sm-2 control-label")
(div ((class "col-sm-10")) (for "tags")) "Tags")
(input ((class "form-control") (div ((class "col-sm-10"))
(type "text") (input ((class "form-control")
(placeholder "tag1 tag2 tag3 ...") (type "text")
(name "tags") (placeholder "tag1 tag2 tag3 ...")
(value ,tags-input) (name "tags")
(id "tags"))))) (value ,tags-input)
(div ((class "form-group")) (id "tags")))))
(div ((class "col-sm-offset-2 col-sm-10")) (div ((class "form-group"))
(button ((type "submit") (div ((class "col-sm-offset-2 col-sm-10"))
(class "btn btn-primary")) (button ((type "submit")
(span ((class "glyphicon glyphicon-search"))) (class "btn btn-primary"))
" Search"))) (span ((class "glyphicon glyphicon-search")))
(div ((class "search-results")) " Search")))
,@(maybe-splice (div ((class "search-results"))
(or (pair? tags) (not (equal? search-text ""))) ,@(maybe-splice
(package-summary-table (package-search search-text tags)))))))) (or (pair? tags) (not (equal? search-text "")))
(package-summary-table (package-search search-text tags)))))))))

169
src/packages.rkt
View File

@ -7,15 +7,20 @@
sorted-package-names sorted-package-names
package-detail package-detail
package-search package-search
refresh-packages!) replace-package!
delete-package!
refresh-packages!
next-fetch-deadline)
(require json) (require json)
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require racket/file) (require racket/port)
(require racket/string) (require racket/string)
(require racket/list) (require racket/list)
(require web-server/private/gzip) (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 package-index-url "http://pkgs.racket-lang.org/pkgs-all.json.gz")
(define all-tags* (set)) (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) (define (fetch-remote-packages)
(hash-keys 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) (define (tombstone? pkg)
all-tags*) (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) (define (sort-package-names names)
(sort names (lambda (a b) (string<? (symbol->string a) (symbol->string b))))) (sort names (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
@ -44,9 +174,6 @@
(define (sorted-package-names) (define (sorted-package-names)
(sort-package-names (all-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) (define (pkg->searchable-text pkg)
(string-join (flatten (list (or (@ pkg authors) '()) (string-join (flatten (list (or (@ pkg authors) '())
(map (match-lambda (map (match-lambda
@ -63,10 +190,12 @@
(or (@ pkg build docs) '())))))) (or (@ pkg build docs) '()))))))
(define ((package-text-matches? pkg) re) (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 (package-search text tags)
(define res (map (lambda (r) (pregexp (format "(?i:~a)" r))) (string-split text))) (define res (map (lambda (r) (pregexp (format "(?i:~a)" r))) (string-split text)))
(define packages (manager-rpc 'packages))
(sort-package-names (sort-package-names
(filter (lambda (package-name) (filter (lambda (package-name)
(define pkg (hash-ref packages package-name)) (define pkg (hash-ref packages package-name))
@ -75,18 +204,6 @@
(for/fold ((ps packages)) ((tag-spec tags)) (for/fold ((ps packages)) ((tag-spec tags))
(match-define (list tag-name include?) tag-spec) (match-define (list tag-name include?) tag-spec)
(for/hash (((package-name pkg) (in-hash ps)) (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))))))) (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!)

9
src/sessions.rkt
View File

@ -3,6 +3,7 @@
(provide session-lifetime (provide session-lifetime
(struct-out session) (struct-out session)
create-session! create-session!
destroy-session!
lookup-session/touch! lookup-session/touch!
lookup-session) lookup-session)
@ -10,7 +11,7 @@
(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 (expiry email password) #:transparent) (struct session (key expiry email password) #:transparent)
(define sessions (make-hash)) (define sessions (make-hash))
@ -26,11 +27,15 @@
(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 (+ (current-inexact-milliseconds) (session-lifetime)) (session session-key
(+ (current-inexact-milliseconds) (session-lifetime))
email email
password)) password))
session-key) session-key)
(define (destroy-session! 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))) (define s (hash-ref sessions session-key (lambda () #f)))
(and s (and s

79
static/editpackage.js
View File

@ -1,48 +1,83 @@
function preenSourceTypes() { function control(e, name) {
$(".package-version-source-type").each(function (index, e) { // Use getElementById here because there are dots (!) in the ID
preenSourceType(e); // 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 preenSourceType(e) {
function controlId(name) {
return "#version__" + e.dataset.packageversion + "__" + name;
}
function showhide1(n, v) { function showhide1(n, v) {
var c = $(controlId(n)); var c = control(e, n + "__group");
if (v) { if (v) {
c.show(); c.show();
} else { } else {
c.hide(); c.hide();
} }
return control(e, n).val();
} }
function showhide(s, gh, gu, gp, gb) { function showhide(s, gh, gu, gp, gb) {
showhide1("simple_url", s); return [showhide1("simple_url", s),
showhide1("g_host", gh); showhide1("g_host", gh),
showhide1("g_user", gu); showhide1("g_user", gu),
showhide1("g_project", gp); showhide1("g_project", gp),
showhide1("g_branch", gb); 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) { switch (e.value) {
case "github": 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; break;
case "git": 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; break;
case "simple": case "simple":
default: default:
showhide(true, false, false, false, false); previewGroup.hide();
pieces = showhide(true, false, false, false, false);
previewUrl = pieces[0];
break; break;
} }
previewInput.html("").append(document.createTextNode(previewUrl));
} }
$(document).ready(function () { $(document).ready(function () {
$(".package-version-source-type").each(function (index, e) { // Stop the enter key from submitting the form using a random submit
$(e).change(function () { // button (there is no sensible default to choose; or rather, the
preenSourceType(e); // 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();
}); });

30
static/style.css
View File

@ -4,6 +4,7 @@
body { body {
padding-top: 50px; padding-top: 50px;
padding-bottom: 50px;
font-family: "Open Sans"; font-family: "Open Sans";
font-weight: 400; font-weight: 400;
color: #1e1e1e; color: #1e1e1e;
@ -18,7 +19,7 @@ body {
.doctags-label { font-weight: bold; } .doctags-label { font-weight: bold; }
table.packages, table.package-details { table.packages, table.package-details, table.package-versions {
width: 100%; width: 100%;
} }
@ -45,3 +46,30 @@ ul.module-list {
} }
.search-results table { margin-top: 3em; } .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%;
}