Progress
This commit is contained in:
Tony Garnock-Jones
parent
4ccb905859
commit
549908aa21
13
src/authentication.rkt
Normal file
13
src/authentication.rkt
Normal file
|
|
@ -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
|
||||
))
|
||||
|
|
@ -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 #"<!DOCTYPE html>\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
|
||||
|
|
|
|||
277
src/main.rkt
277
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))))
|
||||
))))
|
||||
|
|
|
|||
29
src/packages.rkt
Normal file
29
src/packages.rkt
Normal file
|
|
@ -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)
|
||||
(string<? (symbol->string a) (symbol->string b)))))
|
||||
|
||||
(define (package-detail package-name)
|
||||
(hash-ref packages package-name (lambda () #f)))
|
||||
|
||||
(refresh-packages!)
|
||||
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user