Version 1
This commit is contained in:
Tony Garnock-Jones
parent
d3e0a061d9
commit
9629f12b7b
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
802
src/main.rkt
802
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)))))))))
|
||||
|
|
|
|||
169
src/packages.rkt
169
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) (string<? (symbol->string 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!)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
});
|
||||
|
|
|
|||
|
|
@ -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%;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user