diff --git a/src/authentication.rkt b/src/authentication.rkt new file mode 100644 index 0000000..b97ef0e --- /dev/null +++ b/src/authentication.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +(require racket/class) + +(provide userdb<%>) + +(define userdb<%> + (interface () + user-exists? ;; String -> Boolean + create-user! ;; String String -> Void + reset-user-password! ;; String -> Void + credentials-valid? ;; String String -> Boolean + )) diff --git a/src/bootstrap.rkt b/src/bootstrap.rkt index 77601ef..63fde43 100644 --- a/src/bootstrap.rkt +++ b/src/bootstrap.rkt @@ -1,29 +1,40 @@ #lang racket/base ;; Utilities for working with Twitter Bootstrap, http://getbootstrap.com/2.3.2/ -(require racket/match) -(require web-server/servlet) -(require "html-utils.rkt") +(provide bootstrap-project-name + bootstrap-project-link + bootstrap-navigation + bootstrap-active-navigation + bootstrap-navbar-extension-fn + bootstrap-page-stylesheets + bootstrap-page-scripts -(provide bootstrap-active-navigation bootstrap-response bootstrap-radio bootstrap-fieldset bootstrap-button) -(define bootstrap-active-navigation (make-parameter #f)) +(require racket/match) +(require web-server/servlet) +(require "html-utils.rkt") -(define (bootstrap-response #:header-scripts [header-scripts '()] - #:stylesheets [stylesheets '()] - #:project-name [project-name "Project"] - #:project-link [project-link "/"] - #:navigation [navigation '(("Home" "/"))] - #:active-navigation [active (bootstrap-active-navigation)] - title +(define bootstrap-project-name (make-parameter "Project")) +(define bootstrap-project-link (make-parameter "/")) +(define bootstrap-navigation (make-parameter '(("Home" "/")))) +(define bootstrap-active-navigation (make-parameter #f)) +(define bootstrap-navbar-extension-fn (make-parameter (lambda () '()))) +(define bootstrap-page-stylesheets (make-parameter '())) +(define bootstrap-page-scripts (make-parameter '())) + +(define (bootstrap-response title #:title-element [title-element `(h1 ,title)] + #:code [code 200] + #:message [message #"Okay"] . body-contents) (response/xexpr + #:code code + #:message message #:preamble #"\n" `(html (head (meta ((charset "utf-8"))) @@ -32,26 +43,32 @@ (title ,title) (link ((rel "stylesheet") (href "/bootstrap/css/bootstrap.min.css") (type "text/css"))) (link ((rel "stylesheet") (href "/style.css") (type "text/css"))) - ,@(for/list ((sheet stylesheets)) + ,@(for/list ((sheet (bootstrap-page-stylesheets))) `(link ((rel "stylesheet") (href ,sheet) (type "text/css")))) (script ((type "text/javascript") (src "/site.js"))) - ,@(for/list ((header-script header-scripts)) + ,@(for/list ((header-script (bootstrap-page-scripts))) `(script ((type "text/javascript") (src ,header-script))))) (body (nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation")) (div ((class "container")) (div ((class "navbar-header")) - (a ((class "navbar-brand") (href ,project-link)) ,project-name)) + (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 navigation)) + ,@(for/list ((n (bootstrap-navigation))) (match-define (list text url) n) - `(li ,@(maybe-splice (equal? text active) `((class "active"))) - (a ((href ,url)) ,text))))))) + `(li ,@(maybe-splice (equal? text (bootstrap-active-navigation)) + `((class "active"))) + (a ((href ,url)) ,text)))) + ,@((bootstrap-navbar-extension-fn)) + ))) (div ((class "container")) ,title-element ,@body-contents) + (script ((type "text/javascript") + (src "https://ajax.googleapis.com/ajax/libs/jquery/1.11.1/jquery.min.js"))) (script ((type "text/javascript") (src "/bootstrap/js/bootstrap.min.js"))))))) ;; String String XExpr ... -> XExpr diff --git a/src/main.rkt b/src/main.rkt index e8eda7a..37c4dc3 100644 --- a/src/main.rkt +++ b/src/main.rkt @@ -1,11 +1,57 @@ #lang racket/base +(require racket/set) +(require racket/match) +(require racket/format) +(require racket/date) +(require racket/port) (require web-server/servlet) (require "bootstrap.rkt") +(require "html-utils.rkt") +(require "packages.rkt") + +(define nav-index "Package Index") +(define nav-docs "Documentation") + +(bootstrap-project-name + `(a ((class "four columns logo") + (href "http://www.racket-lang.org/")) + (img ((src "http://pkgs.racket-lang.org/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/"))) + +(bootstrap-navbar-extension-fn + (lambda () + `( + (form ((class "navbar-form navbar-right") + (role "form")) + (div ((class "form-group")) + (input ((type "text") + (placeholder "Email") + (class "form-control")))) + (div ((class "form-group")) + (input ((type "password") + (placeholder "Password") + (class "form-control")))) + (button ((type "submit") + (class "btn btn-success")) + "Sign in")) + ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-values (request-handler named-url) (dispatch-rules [("") main-page] + [("package" (string-arg)) package-page] )) (module+ main @@ -14,8 +60,231 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (main-page request) - (parameterize ((bootstrap-active-navigation "Home")) - (bootstrap-response "Hello World" - `(p "Hi there!")))) +(define (package-link package-name) + (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)] + [(list _ n) (values n #f)])) + +(define (doc-link doc) + (define-values (docset-name docset-url) (doc-destruct doc)) + (if docset-url + (buildhost-link docset-url docset-name) + `(del ,docset-name))) + +(define (tag-link tag-name) + `(a ((href "TODO")) ,tag-name)) + +(define (buildhost-link #:attributes [attributes '()] url-suffix label) + `(a (,@attributes + (href ,(format "http://pkg-build.racket-lang.org/~a" url-suffix))) ,label)) + +(define (authors-list authors) + `(ul ((class "authors")) ,@(for/list ((author authors)) `(li ,(author-link author))))) + +(define (package-links #:pretty? [pretty? #t] package-names) + (if (and pretty? (null? (or package-names '()))) + `(span ((class "packages none")) "None") + `(ul ((class "list-inline packages")) + ,@(for/list ((p package-names)) `(li ,(package-link p)))))) + +(define (doc-links docs) + `(ul ((class "list-inline doclinks")) + ,@(for/list ((doc (or docs '()))) `(li ,(doc-link doc))))) + +(define (tag-links tags) + `(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)")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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 (main-page request) + (bootstrap-response "Racket Package Index" + #:title-element "" + `(div ((class "jumbotron")) + (h1 "Racket Package Index") + (p "These are the currently-registered 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)])))))) + +(define (package-page request package-name-str) + (define package-name (string->symbol package-name-str)) + (define pkg (package-detail package-name)) + (define default-version (hash-ref (or (@ pkg versions) (hash)) 'default (lambda () #f))) + (if (not pkg) + (bootstrap-response #:code 404 + #:message #"No such package" + "Package not found" + `(div "The package " (code ,package-name-str) " does not exist.")) + (bootstrap-response (~a package-name) + #:title-element "" + `(div ((class "jumbotron")) + (h1 ,(~a package-name)) + (p ,(@ pkg description)) + (div ,@(let ((docs (or (@ pkg build docs) '()))) + (match docs + [(list) + `()] + [(list doc) + (define-values (n u) (doc-destruct doc)) + (list (buildhost-link + #:attributes `((class "btn btn-success btn-lg")) + u + "Documentation"))] + [_ + `((button ((class "btn btn-success btn-lg dropdown-toggle") + (data-toggle "dropdown")) + "Documentation " + (span ((class "caret")))) + (ul ((class "dropdown-menu") + (role "menu")) + ,@(for/list ((doc docs)) `(li ,(doc-link doc)))))])) + + ;; Heuristic guess as to whether we should present a "browse" + ;; link or a "download" link. + " " + ,(if (equal? (@ default-version source) + (@ default-version source_url)) + `(a ((class "btn btn-default btn-lg") + (href ,(@ default-version source_url))) + (span ((class "glyphicon glyphicon-download"))) + " Snapshot") + `(a ((class "btn btn-default btn-lg") + (href ,(@ default-version source_url))) + (span ((class "glyphicon glyphicon-link"))) + " Code")) + )) + + (if (@ pkg checksum-error) + `(div ((class "alert alert-danger") + (role "alert")) + (span ((class "label label-danger")) + "Checksum error") + " The package checksum does not match" + " the package source code.") + "") + + `(table ((class "package-details")) + (tr (th "Authors") + (td ,(authors-list (@ pkg authors)))) + (tr (th "Documentation") + (td ,(doc-links (@ pkg build docs)))) + (tr (th "Tags") + (td ,@(for/list ((tag (@ pkg tags))) (tag-link tag)))) + (tr (th "Last updated") + (td ,(utc->string (@ pkg last-updated)))) + (tr (th "Ring") + (td ,(~a (@ pkg ring)))) + (tr (th "Conflicts") + (td ,(package-links (@ pkg conflicts)))) + (tr (th "Dependencies") + (td ,(package-links (@ pkg dependencies)))) + (tr (th "Most recent build results") + (td (ul ((class "build-results")) + ,@(maybe-splice + (@ pkg build success-log) + `(li "Compiled successfully: " + ,(buildhost-link (@ pkg build success-log) "transcript"))) + ,@(maybe-splice + (@ pkg build failure-log) + `(li "Compiled unsuccessfully: " + ,(buildhost-link (@ pkg build failure-log) "transcript"))) + ,@(maybe-splice + (@ pkg build conflicts-log) + `(li "Conflicts: " + ,(buildhost-link (@ pkg build conflicts-log) "details"))) + ,@(maybe-splice + (@ pkg build dep-failure-log) + `(li "Dependency problems: " + ,(buildhost-link (@ pkg build dep-failure-log) "details"))) + ))) + (tr (th "Modules") + (td (ul ((class "module-list")) + ,@(for/list ((mod (@ pkg modules))) + (match-define (list kind path) mod) + `(li ((class ,kind)) ,path))))) + ,@(let* ((vs (or (@ pkg versions) (hash))) + (empty-checksum "9f098dddde7f217879070816090c1e8e74d49432") + (vs (for/hash (((k v) (in-hash vs)) + #:when (not (equal? (@ v checksum) + empty-checksum))) + (values k v)))) + (maybe-splice + (not (hash-empty? vs)) + `(tr (th "Versions") + (td (table ((class "package-versions")) + (tr (th "Version") + (th "Source") + (th "Checksum")) + ,@(for/list + (((version-sym v) (in-hash vs))) + `(tr + (td ,(~a version-sym)) + (td (a ((href ,(@ v source_url))) + ,(@ v source))) + (td ,(@ v checksum))))))))) + (tr (th "Last checked") + (td ,(utc->string (@ pkg last-checked)))) + (tr (th "Last edited") + (td ,(utc->string (@ pkg last-edit)))) + )))) diff --git a/src/packages.rkt b/src/packages.rkt new file mode 100644 index 0000000..42624c2 --- /dev/null +++ b/src/packages.rkt @@ -0,0 +1,29 @@ +#lang racket/base + +(provide all-package-names + sorted-package-names + package-detail + refresh-packages!) + +(require json) +(require racket/file) +(require web-server/private/gzip) + +(define packages #f) + +(define (refresh-packages!) + (set! packages (bytes->jsexpr (gunzip/bytes (file->bytes "../pkgs-all.json.gz"))))) + +(define (all-package-names) + (hash-keys packages)) + +(define (sorted-package-names) + (sort (all-package-names) + (lambda (a b) + (stringstring a) (symbol->string b))))) + +(define (package-detail package-name) + (hash-ref packages package-name (lambda () #f))) + +(refresh-packages!) + diff --git a/static/style.css b/static/style.css index a8fc8a1..b4200d9 100644 --- a/static/style.css +++ b/static/style.css @@ -1,3 +1,45 @@ +@charset "UTF-8"; +@import url(http://fonts.googleapis.com/css?family=Open+Sans:500,400,300,600,700); +@import url(http://fonts.googleapis.com/css?family=Inconsolata); + body { padding-top: 50px; + font-family: "Open Sans"; + font-weight: 400; + color: #1e1e1e; + -webkit-font-smoothing: antialiased; +} + +.navbar { background: black; } + +.build_green { background-color: #ccffcc; } +.build_yellow { background-color: #ffffcc; } +.build_red { background-color: #ffcccc; } + +.doctags-label { font-weight: bold; } + +table.packages, table.package-details { + width: 100%; +} + +table { + border: 1px solid #e5e5e5; +} +td, th { + border-top: 1px solid #e5e5e5; + vertical-align: top; + padding: 0.5em; +} + +ul.list-inline { display: inline-block; } +ul.list-inline li { padding-right: 0; } + +ul.authors { list-style: none; padding: 0; } +ul.authors a { color: black; } + +table.packages h2 { font-size: 160%; margin-top: 0; } + +ul.build-results, +ul.module-list { + list-style: none; padding: 0; }