diff --git a/src/html-utils.rkt b/src/html-utils.rkt
index e49f317..717e04b 100644
--- a/src/html-utils.rkt
+++ b/src/html-utils.rkt
@@ -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 ...))]))
diff --git a/src/main.rkt b/src/main.rkt
index 37c4dc3..e6fe5a6 100644
--- a/src/main.rkt
+++ b/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)))))))
diff --git a/src/packages.rkt b/src/packages.rkt
index 42624c2..d2c6cb2 100644
--- a/src/packages.rkt
+++ b/src/packages.rkt
@@ -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) (stringstring a) (symbol->string b)))))
+
(define (sorted-package-names)
- (sort (all-package-names)
- (lambda (a b)
- (stringstring 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!)
diff --git a/static/style.css b/static/style.css
index b4200d9..3b9042a 100644
--- a/static/style.css
+++ b/static/style.css
@@ -43,3 +43,5 @@ ul.build-results,
ul.module-list {
list-style: none; padding: 0;
}
+
+.search-results table { margin-top: 3em; }