More progress
This commit is contained in:
Tony Garnock-Jones
parent
549908aa21
commit
26df31d1f6
|
|
@ -14,7 +14,20 @@
|
|||
|
||||
;; Extracts named single-valued bindings from the given request.
|
||||
;; If a given binding is missing, the extracted value will be #f.
|
||||
(define-syntax-rule (define-form-bindings req (name ...))
|
||||
(define-syntax-rule (define-form-bindings req (specs ...))
|
||||
(begin (define bs (request-bindings req))
|
||||
(define name (and (exists-binding? 'name bs) (extract-binding/single 'name bs)))
|
||||
...))
|
||||
(define-form-bindings* bs (specs ...))))
|
||||
|
||||
(define-syntax define-form-bindings*
|
||||
(syntax-rules ()
|
||||
[(_ bs ())
|
||||
(begin)]
|
||||
[(_ bs ([name fieldname defaultval] rest ...))
|
||||
(begin (define name (if (exists-binding? 'fieldname bs)
|
||||
(extract-binding/single 'fieldname bs)
|
||||
defaultval))
|
||||
(define-form-bindings* bs (rest ...)))]
|
||||
[(_ bs ([name defaultval] rest ...))
|
||||
(define-form-bindings* bs ([name name defaultval] rest ...))]
|
||||
[(_ bs (name rest ...))
|
||||
(define-form-bindings* bs ([name #f] rest ...))]))
|
||||
|
|
|
|||
175
src/main.rkt
175
src/main.rkt
|
|
@ -5,6 +5,8 @@
|
|||
(require racket/format)
|
||||
(require racket/date)
|
||||
(require racket/port)
|
||||
(require racket/string)
|
||||
(require net/uri-codec)
|
||||
(require web-server/servlet)
|
||||
(require "bootstrap.rkt")
|
||||
(require "html-utils.rkt")
|
||||
|
|
@ -51,6 +53,7 @@
|
|||
(define-values (request-handler named-url)
|
||||
(dispatch-rules
|
||||
[("") main-page]
|
||||
[("search") search-page]
|
||||
[("package" (string-arg)) package-page]
|
||||
))
|
||||
|
||||
|
|
@ -64,9 +67,6 @@
|
|||
(define package-name-str (~a package-name))
|
||||
`(a ((href ,(named-url package-page package-name-str))) ,package-name-str))
|
||||
|
||||
(define (author-link author-name)
|
||||
`(a ((href "TODO")) ,author-name))
|
||||
|
||||
(define (doc-destruct doc)
|
||||
(match doc
|
||||
[(list _ n u) (values n u)]
|
||||
|
|
@ -78,8 +78,16 @@
|
|||
(buildhost-link docset-url docset-name)
|
||||
`(del ,docset-name)))
|
||||
|
||||
(define (tags-page-url tags)
|
||||
(format "~a?~a"
|
||||
(named-url search-page)
|
||||
(alist->form-urlencoded (list (cons 'tags (string-join tags))))))
|
||||
|
||||
(define (author-link author-name)
|
||||
`(a ((href ,(tags-page-url (list (format "author:~a" author-name))))) ,author-name))
|
||||
|
||||
(define (tag-link tag-name)
|
||||
`(a ((href "TODO")) ,tag-name))
|
||||
`(a ((href ,(tags-page-url (list tag-name)))) ,tag-name))
|
||||
|
||||
(define (buildhost-link #:attributes [attributes '()] url-suffix label)
|
||||
`(a (,@attributes
|
||||
|
|
@ -104,15 +112,52 @@
|
|||
(define (utc->string utc)
|
||||
(string-append (date->string (seconds->date utc #f) #t) " (UTC)"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax @
|
||||
(syntax-rules ()
|
||||
[(_ v) v]
|
||||
[(_ v k rest ...) (@ (@ref v 'k) rest ...)]))
|
||||
|
||||
(define (@ref v k)
|
||||
(and v (hash-ref v k (lambda () #f))))
|
||||
(define (package-summary-table package-names)
|
||||
`(table
|
||||
((class "packages sortable"))
|
||||
(tr
|
||||
(th "Package")
|
||||
(th "Description")
|
||||
(th "Build"))
|
||||
,@(maybe-splice (null? package-names)
|
||||
`(tr (td ((colspan "3"))
|
||||
(div ((class "alert alert-info"))
|
||||
"No packages found."))))
|
||||
,@(for/list ((package-name package-names))
|
||||
(define pkg (package-detail package-name))
|
||||
`(tr
|
||||
(td (h2 ,(package-link package-name))
|
||||
,(authors-list (@ pkg authors))
|
||||
;; recently-updated?
|
||||
)
|
||||
(td (p ,(@ pkg description))
|
||||
,@(maybe-splice
|
||||
(pair? (@ pkg build docs))
|
||||
`(div
|
||||
(span ((class "doctags-label")) "Docs: ")
|
||||
,(doc-links (@ pkg build docs))))
|
||||
,@(maybe-splice
|
||||
(pair? (@ pkg tags))
|
||||
`(div
|
||||
(span ((class "doctags-label")) "Tags: ")
|
||||
,(tag-links (@ pkg tags)))))
|
||||
,(cond
|
||||
[(@ pkg build failure-log)
|
||||
`(td ((class "build_red"))
|
||||
,(buildhost-link (@ pkg build failure-log) "fails"))]
|
||||
[(and (@ pkg build success-log)
|
||||
(@ pkg build dep-failure-log))
|
||||
`(td ((class "build_yellow"))
|
||||
,(buildhost-link (@ pkg build success-log)
|
||||
"succeeds")
|
||||
" with "
|
||||
,(buildhost-link (@ pkg build dep-failure-log)
|
||||
"dependency problems"))]
|
||||
[(@ pkg build success-log)
|
||||
`(td ((class "build_green"))
|
||||
,(buildhost-link (@ pkg build success-log) "succeeds"))]
|
||||
[else
|
||||
`(td)])))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -121,51 +166,22 @@
|
|||
#:title-element ""
|
||||
`(div ((class "jumbotron"))
|
||||
(h1 "Racket Package Index")
|
||||
(p "These are the currently-registered packages available via the "
|
||||
(p "These are the packages available via the "
|
||||
(a ((href "docs.racket-lang.org/pkg/getting-started.html"))
|
||||
"Racket package system") "."))
|
||||
|
||||
`(table
|
||||
((class "packages sortable"))
|
||||
(tr
|
||||
(th "Package")
|
||||
(th "Description")
|
||||
(th "Build"))
|
||||
,@(for/list ((package-name (sorted-package-names)))
|
||||
(define pkg (package-detail package-name))
|
||||
`(tr
|
||||
(td (h2 ,(package-link package-name))
|
||||
,(authors-list (@ pkg authors))
|
||||
;; recently-updated?
|
||||
)
|
||||
(td (p ,(@ pkg description))
|
||||
,@(maybe-splice
|
||||
(pair? (@ pkg build docs))
|
||||
`(div
|
||||
(span ((class "doctags-label")) "Docs: ")
|
||||
,(doc-links (@ pkg build docs))))
|
||||
,@(maybe-splice
|
||||
(pair? (@ pkg tags))
|
||||
`(div
|
||||
(span ((class "doctags-label")) "Tags: ")
|
||||
,(tag-links (@ pkg tags)))))
|
||||
,(cond
|
||||
[(@ pkg build failure-log)
|
||||
`(td ((class "build_red"))
|
||||
,(buildhost-link (@ pkg build failure-log) "fails"))]
|
||||
[(and (@ pkg build success-log)
|
||||
(@ pkg build dep-failure-log))
|
||||
`(td ((class "build_yellow"))
|
||||
,(buildhost-link (@ pkg build success-log)
|
||||
"succeeds")
|
||||
" with "
|
||||
,(buildhost-link (@ pkg build dep-failure-log)
|
||||
"dependency problems"))]
|
||||
[(@ pkg build success-log)
|
||||
`(td ((class "build_green"))
|
||||
,(buildhost-link (@ pkg build success-log) "succeeds"))]
|
||||
[else
|
||||
`(td)]))))))
|
||||
"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))))))
|
||||
|
||||
(define (package-page request package-name-str)
|
||||
(define package-name (string->symbol package-name-str))
|
||||
|
|
@ -230,7 +246,7 @@
|
|||
(tr (th "Documentation")
|
||||
(td ,(doc-links (@ pkg build docs))))
|
||||
(tr (th "Tags")
|
||||
(td ,@(for/list ((tag (@ pkg tags))) (tag-link tag))))
|
||||
(td ,(tag-links (@ pkg tags))))
|
||||
(tr (th "Last updated")
|
||||
(td ,(utc->string (@ pkg last-updated))))
|
||||
(tr (th "Ring")
|
||||
|
|
@ -288,3 +304,46 @@
|
|||
(tr (th "Last edited")
|
||||
(td ,(utc->string (@ pkg last-edit))))
|
||||
))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (search-page 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)))))))
|
||||
|
|
|
|||
|
|
@ -1,29 +1,92 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide all-package-names
|
||||
(provide @
|
||||
@ref
|
||||
all-package-names
|
||||
all-tags
|
||||
sorted-package-names
|
||||
package-detail
|
||||
package-search
|
||||
refresh-packages!)
|
||||
|
||||
(require json)
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/file)
|
||||
(require racket/string)
|
||||
(require racket/list)
|
||||
(require web-server/private/gzip)
|
||||
|
||||
(define packages #f)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (refresh-packages!)
|
||||
(set! packages (bytes->jsexpr (gunzip/bytes (file->bytes "../pkgs-all.json.gz")))))
|
||||
(define-syntax @
|
||||
(syntax-rules ()
|
||||
[(_ v) v]
|
||||
[(_ v k rest ...) (@ (@ref v 'k) rest ...)]))
|
||||
|
||||
(define (@ref v k)
|
||||
(and v (hash-ref v k (lambda () #f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define packages (hash))
|
||||
(define all-tags* (set))
|
||||
|
||||
(define (all-package-names)
|
||||
(hash-keys packages))
|
||||
|
||||
(define (all-tags)
|
||||
all-tags*)
|
||||
|
||||
(define (sort-package-names names)
|
||||
(sort names (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
|
||||
|
||||
(define (sorted-package-names)
|
||||
(sort (all-package-names)
|
||||
(lambda (a b)
|
||||
(string<? (symbol->string a) (symbol->string b)))))
|
||||
(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
|
||||
[(list _ path) path]
|
||||
[_ '()])
|
||||
(or (@ pkg modules) '()))
|
||||
(or (@ pkg name) '())
|
||||
(or (@ pkg description) '())
|
||||
(or (@ pkg source) '())
|
||||
(or (@ pkg tags) '())
|
||||
(map (match-lambda
|
||||
[(list _ n _) n]
|
||||
[_ '()])
|
||||
(or (@ pkg build docs) '()))))))
|
||||
|
||||
(define ((package-text-matches? pkg) re)
|
||||
(regexp-match? re (@ pkg _SEARCHABLE-TEXT_)))
|
||||
|
||||
(define (package-search text tags)
|
||||
(define res (map (lambda (r) (pregexp (format "(?i:~a)" r))) (string-split text)))
|
||||
(sort-package-names
|
||||
(filter (lambda (package-name)
|
||||
(define pkg (hash-ref packages package-name))
|
||||
(andmap (package-text-matches? pkg) res))
|
||||
(hash-keys
|
||||
(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)))
|
||||
(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!)
|
||||
|
||||
|
|
|
|||
|
|
@ -43,3 +43,5 @@ ul.build-results,
|
|||
ul.module-list {
|
||||
list-style: none; padding: 0;
|
||||
}
|
||||
|
||||
.search-results table { margin-top: 3em; }
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user