suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Clean up repetition and boilerplate in markup.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-09 09:21:55 -05:00
parent 6e0a53fedf
commit f6fe653f66
3 changed files with 190 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/bootstrap.rkt
View File

@ -13,15 +13,15 @@
bootstrap-response bootstrap-response
bootstrap-redirect bootstrap-redirect
bootstrap-radio
bootstrap-fieldset
bootstrap-button
add-classes
glyphicon) glyphicon)
(require racket/match) (require racket/match)
(require racket/string)
(require web-server/servlet) (require web-server/servlet)
(require "html-utils.rkt") (require "html-utils.rkt")
(require "xexpr-utils.rkt")
(define bootstrap-project-name (make-parameter "Project")) (define bootstrap-project-name (make-parameter "Project"))
(define bootstrap-project-link (make-parameter "/")) (define bootstrap-project-link (make-parameter "/"))
@ -33,6 +33,7 @@
(define bootstrap-page-scripts (make-parameter '())) (define bootstrap-page-scripts (make-parameter '()))
(define bootstrap-cookies (make-parameter '())) (define bootstrap-cookies (make-parameter '()))
;; String [#:title-element XExpr] [#:code Integer] [#:message Bytes] [XExpr ...] -> Response
(define (bootstrap-response title (define (bootstrap-response title
#:title-element [title-element `(h1 ,title)] #:title-element [title-element `(h1 ,title)]
#:code [code 200] #:code [code 200]
@ -80,6 +81,7 @@
,@(for/list ((script (bootstrap-page-scripts))) ,@(for/list ((script (bootstrap-page-scripts)))
`(script ((type "text/javascript") (src ,script)))))))) `(script ((type "text/javascript") (src ,script))))))))
;; String [#:permanent? Boolean] [#:headers (Listof Header)] -> Response
(define (bootstrap-redirect url (define (bootstrap-redirect url
#:permanent? [permanent? #f] #:permanent? [permanent? #f]
#:headers [headers '()]) #:headers [headers '()])
@ -88,33 +90,22 @@
#:headers (append (map cookie->header (bootstrap-cookies)) #:headers (append (map cookie->header (bootstrap-cookies))
headers))) headers)))
;; String String XExpr ... -> XExpr ;; (Listof (U Symbol String)) XExpr -> XExpr
;; Constructs Bootstrap boilerplate for a radio button. (define (add-classes classes x)
(define (bootstrap-radio #:checked [checked #f] field-name field-value . label-contents) (define class-strs (map (lambda (c) (if (symbol? c) (symbol->string c) c)) classes))
`(label ((class "radio")) (xexpr-case x
(input ((type "radio") (lambda (content)
(name ,field-name) `(span ((class ,(string-join class-strs))) ,content))
(value ,field-value) (lambda (tag attrs kids)
,@(maybe-splice checked '(checked "checked")))) (match (assq 'class attrs)
,@label-contents)) [#f
`(,tag ((class ,(string-join class-strs))
;; [#:legend (Option String)] [#:style Style] XExpr ... -> XExpr ,@attrs)
;; where Style is one of 'inline, 'horizontal, or 'normal. ,@kids)]
(define (bootstrap-fieldset #:legend [legend #f] [(and (list 'class existing-class) entry)
#:style [style 'normal] `(,tag ((class ,(string-join (cons existing-class class-strs)))
. contents) ,@(remove entry attrs))
`(fieldset ,@kids)]))))
,@(maybe-splice legend `(legend ,legend))
,@contents))
;; [#:id (Option String)] [#:type (Option String)] XExpr ... -> XExpr
(define (bootstrap-button #:id [id #f]
#:type [type "submit"]
. contents)
`(button ((class "btn")
,@(maybe-splice id `(id ,id))
,@(maybe-splice type `(type ,type)))
,@contents))
;; Symbol -> XExpr ;; Symbol -> XExpr
(define (glyphicon type) (define (glyphicon type)

291
src/main.rkt
View File

@ -189,6 +189,57 @@
(cons 'passwd password) (cons 'passwd password)
(cons 'code code)))) (cons 'code code))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f])
`(input ((class "form-control")
(type ,type)
(name ,name)
(id ,name)
,@(maybe-splice placeholder `(placeholder ,placeholder))
(value ,initial-value))))
(define email-input (generic-input "email"))
(define password-input (generic-input "password"))
(define text-input (generic-input "text"))
(define (label for . content)
`(label ((class "control-label") ,@(maybe-splice for `(for ,for)))
,@content))
(define (primary-button . content)
`(button ((type "submit")
(class "btn btn-primary"))
,@content))
(define (generic-row class)
(define (wrap cell)
(match cell
[(cons 'label _) cell]
[_ `(div ,cell)]))
(lambda (#:id [id #f] . args)
`(div (,@(maybe-splice id `(id ,id))
(class ,class))
,@(let loop ((args args))
(match args
[(list* _ _ #f rest)
(loop rest)]
[(list* 0 0 cell rest)
(cons cell (loop rest))]
[(list* 0 w cell rest)
(cons (add-classes (list (format "col-sm-~a" w)) (wrap cell))
(loop rest))]
[(list* o w cell rest)
(cons (add-classes (list (format "col-sm-offset-~a col-sm-~a" o w)) (wrap cell))
(loop rest))]
['()
'()])))))
(define form-group (generic-row "form-group"))
(define row (generic-row "row"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (login-page [error-message #f]) (define (login-page [error-message #f])
(send/suspend/dispatch (send/suspend/dispatch
(lambda (embed-url) (lambda (embed-url)
@ -197,40 +248,19 @@
(method "post") (method "post")
(action ,(embed-url process-login-credentials)) (action ,(embed-url process-login-credentials))
(role "form")) (role "form"))
(div ((class "form-group")) ,(form-group 2 2 (label "email" "Email address")
(label ((class "col-sm-offset-2 col-sm-2 control-label") 0 5 (email-input "email"))
(for "email")) "Email address:") ,(form-group 2 2 (label "password" "Password:")
(div ((class "col-sm-5")) 0 5 (password-input "password"))
(input ((class "form-control") ,(form-group 4 5
(type "email") `(a ((href ,(embed-url (lambda (req) (register-page)))))
(name "email") "Need to reset your password?"))
(value "")
(id "email")))))
(div ((class "form-group"))
(label ((class "col-sm-offset-2 col-sm-2 control-label")
(for "password")) "Password:")
(div ((class "col-sm-5"))
(input ((class "form-control")
(type "password")
(name "password")
(value "")
(id "password")))))
(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?")))
,@(maybe-splice ,@(maybe-splice
error-message error-message
`(div ((class "form-group")) (form-group 4 5
(div ((class "col-sm-offset-4 col-sm-5")) `(div ((class "alert alert-danger"))
(div ((class "alert alert-danger")) (p ,error-message))))
(p ,error-message))))) ,(form-group 4 5 (primary-button "Log in")))))))
(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 (process-login-credentials request)
(define-form-bindings request (email password)) (define-form-bindings request (email password))
@ -259,53 +289,20 @@
(method "post") (method "post")
(action ,(embed-url apply-account-code)) (action ,(embed-url apply-account-code))
(role "form")) (role "form"))
(div ((class "form-group")) ,(form-group 2 2 (label "email" "Email address")
(label ((class "col-sm-offset-2 col-sm-2 control-label") 0 5 (email-input "email" email))
(for "email")) "Email address:") ,(form-group 2 2 (label "code" "Code")
(div ((class "col-sm-5")) 0 5 (text-input "code" code))
(input ((class "form-control") ,(form-group 2 2 (label "password" "Password")
(type "email") 0 5 (password-input "password"))
(name "email") ,(form-group 2 2 (label "password" "Confirm password")
(value ,email) 0 5 (password-input "confirm_password"))
(id "email")))))
(div ((class "form-group"))
(label ((class "col-sm-offset-2 col-sm-2 control-label")
(for "code")) "Code:")
(div ((class "col-sm-5"))
(input ((class "form-control")
(type "text")
(name "code")
(value ,code)
(id "code")))))
(div ((class "form-group"))
(label ((class "col-sm-offset-2 col-sm-2 control-label")
(for "password")) "Password:")
(div ((class "col-sm-5"))
(input ((class "form-control")
(type "password")
(name "password")
(value "")
(id "password")))))
(div ((class "form-group"))
(label ((class "col-sm-offset-2 col-sm-2 control-label")
(for "password")) "Confirm password:")
(div ((class "col-sm-5"))
(input ((class "form-control")
(type "password")
(name "confirm_password")
(value "")
(id "confirm_password")))))
,@(maybe-splice ,@(maybe-splice
error-message error-message
`(div ((class "form-group")) (form-group 4 5
(div ((class "col-sm-offset-4 col-sm-5")) `(div ((class "alert alert-danger"))
(div ((class "alert alert-danger")) (p ,error-message))))
(p ,error-message))))) ,(form-group 4 5 (primary-button "Continue"))))
(div ((class "form-group"))
(div ((class "col-sm-offset-4 col-sm-5"))
(button ((type "submit")
(class "btn btn-primary"))
"Continue")))))
`(div `(div
(h1 "Need a code?") (h1 "Need a code?")
(p "Enter your email address below, and we'll send you one.") (p "Enter your email address below, and we'll send you one.")
@ -313,20 +310,9 @@
(method "post") (method "post")
(action ,(embed-url notify-of-emailing)) (action ,(embed-url notify-of-emailing))
(role "form")) (role "form"))
(div ((class "form-group")) ,(form-group 2 2 (label "email" "Email address")
(label ((class "col-sm-offset-2 col-sm-2 control-label") 0 5 (email-input "email_for_code"))
(for "email")) "Email address:") ,(form-group 4 5 (primary-button "Email me a code"))))))))
(div ((class "col-sm-5"))
(input ((class "form-control")
(type "email")
(name "email_for_code")
(value "")
(id "email_for_code")))))
(div ((class "form-group"))
(div ((class "col-sm-offset-4 col-sm-5"))
(button ((type "submit")
(class "btn btn-primary"))
"Email me a code")))))))))
(define (apply-account-code request) (define (apply-account-code request)
(define-form-bindings request (email code password confirm_password)) (define-form-bindings request (email code password confirm_password))
@ -497,14 +483,7 @@
" packages in the index.") " packages in the index.")
(form ((role "form") (form ((role "form")
(action ,(named-url search-page))) (action ,(named-url search-page)))
(div ((class "form-group")) ,(text-input "q" #:placeholder "Search packages")))
(input ((class "form-control")
(type "text")
(placeholder "Search packages")
(name "q")
(value "")
(id "q"))))
))
(package-summary-table package-name-list))))) (package-summary-table package-name-list)))))
(define (logout-page request) (define (logout-page request)
@ -730,22 +709,12 @@
(match-define (list version source) v) (match-define (list version source) v)
(define (control-name c) (format "version__~a__~a" version c)) (define (control-name c) (format "version__~a__~a" version c))
(define (group-name c) (format "version__~a__~a__group" version c)) (define (group-name c) (format "version__~a__~a__group" version c))
(define (textfield name label value [placeholder ""]) (define (textfield name label-text value [placeholder ""])
`(div ((id ,(group-name name)) (row #:id (group-name name)
(class "row")) 0 3
,@(maybe-splice (and label-text (label (control-name name) label-text))
label 0 (if label-text 9 12)
`(div ((class "col-sm-3")) (text-input (control-name name) value #:placeholder placeholder)))
(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) (define-values (source-type simple-url g-host g-user g-project g-branch)
(match source (match source
[(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?" [(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?"
@ -766,9 +735,8 @@
(name "action") (name "action")
(value ,(control-name "delete"))) (value ,(control-name "delete")))
,(glyphicon 'trash)))) ,(glyphicon 'trash))))
(td (div ((class "row")) (td ,(row
(div ((class "col-sm-3")) 0 3 `(div ((id ,(group-name "type")))
(div ((id ,(group-name "type")))
(select ((class "package-version-source-type") (select ((class "package-version-source-type")
(data-packageversion ,version) (data-packageversion ,version)
(name ,(control-name "type"))) (name ,(control-name "type")))
@ -780,13 +748,12 @@
"Git Repository") "Git Repository")
,(package-source-option source-type ,(package-source-option source-type
"simple" "simple"
"Simple URL")))) "Simple URL")))
(div ((id ,(group-name "fields")) 0 9 `(div ((id ,(group-name "fields")))
(class "col-sm-9"))
(div ((id ,(group-name "urlpreview")) (div ((id ,(group-name "urlpreview"))
(class "row")) (class "row"))
(div ((class "col-sm-3")) (div ((class "col-sm-3"))
(label ((class "control-label")) "URL preview")) ,(label #f "URL preview"))
(div ((class "col-sm-9")) (div ((class "col-sm-9"))
(span ((class "form-control disabled") (span ((class "form-control disabled")
(disabled "disabled") (disabled "disabled")
@ -795,16 +762,11 @@
,(textfield "g_host" "Repo Host" g-host) ,(textfield "g_host" "Repo Host" g-host)
,(textfield "g_user" "Repo User" g-user) ,(textfield "g_user" "Repo User" g-user)
,(textfield "g_project" "Repo Project" g-project) ,(textfield "g_project" "Repo Project" g-project)
,(textfield "g_branch" "Repo Branch" g-branch "master") ,(textfield "g_branch" "Repo Branch" g-branch "master"))))))
)))))
(tr (td ((colspan "2")) (tr (td ((colspan "2"))
(div ((class "form-inline")) (div ((class "form-inline"))
(input ((class "form-control") ,(text-input "new_version" #:placeholder "x.y.z")
(type "text")
(name "new_version")
(id "new_version")
(placeholder "x.y.z")
(value "")))
" " " "
(button ((class "btn btn-success btn-xs") (button ((class "btn btn-success btn-xs")
(type "submit") (type "submit")
@ -830,36 +792,21 @@
(div ((class "container")) ;; TODO: remove?? (div ((class "container")) ;; TODO: remove??
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
(label ((for "name") ,(label "name" "Package Name")
(class "control-label")) ,(text-input "name" (~a (draft-package-name draft))))
"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")) (div ((class "form-group col-sm-6"))
(label ((for "tags") ,(label "tags" "Package Tags (space-separated)")
(class "control-label")) ,(text-input "tags" (string-join
"Package Tags (space-separated)") (draft-package-tags draft)))))
(input ((class "form-control")
(type "text")
(name "tags")
(id "tags")
(value ,(string-join
(draft-package-tags draft)))))))
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
(label ((for "description") ,(label "description" "Package Description")
(class "control-label"))
"Package Description")
(textarea ((class "form-control") (textarea ((class "form-control")
(name "description") (name "description")
(id "description")) (id "description"))
,(draft-package-description draft))) ,(draft-package-description draft)))
(div ((class "form-group col-sm-6")) (div ((class "form-group col-sm-6"))
(label ((for "authors") ,(label "authors"
(class "control-label"))
"Author email addresses (one per line)") "Author email addresses (one per line)")
(textarea ((class "form-control") (textarea ((class "form-control")
(name "authors") (name "authors")
@ -868,8 +815,7 @@
"\n")))) "\n"))))
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-12")) (div ((class "form-group col-sm-12"))
(label ((class "control-label")) ,(label #f "Package Versions & Sources")
"Package Versions & Sources")
,(build-versions-table))) ,(build-versions-table)))
(div ((class "row")) (div ((class "row"))
(div ((class "form-group col-sm-12")) (div ((class "form-group col-sm-12"))
@ -1118,35 +1064,20 @@
(bootstrap-response "Search Racket Package Index" (bootstrap-response "Search Racket Package Index"
`(form ((class "form-horizontal") `(form ((class "form-horizontal")
(role "form")) (role "form"))
(div ((class "form-group")) ,(form-group 0 2 (label "q" "Search terms")
(label ((class "col-sm-2 control-label") 0 10 (text-input "q" search-text
(for "q")) "Search terms") #:placeholder
(div ((class "col-sm-10")) "Enter free-form text to match here"))
(input ((class "form-control") ,(form-group 0 2 (label "tags" "Tags")
(type "text") 0 10(text-input "tags" tags-input
(placeholder "Enter free-form text to match here") #:placeholder
(name "q") "tag1 tag2 tag3 ..."))
(value ,search-text) ,(form-group 2 10 (primary-button (glyphicon 'search) " Search"))
(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"))
,(glyphicon 'search) " Search")))
(div ((class "search-results")) (div ((class "search-results"))
,@(maybe-splice ,@(maybe-splice
(or (pair? tags) (not (equal? search-text ""))) (or (pair? tags) (not (equal? search-text "")))
(let ((package-name-list (package-search search-text tags))) (let ((package-name-list (package-search search-text tags)))
`(div `(div
(p ((class "package-count")) ,(format "~a packages found" (length package-name-list))) (p ((class "package-count"))
,(format "~a packages found" (length package-name-list)))
,(package-summary-table package-name-list)))))))))) ,(package-summary-table package-name-list))))))))))

35
src/xexpr-utils.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang racket/base
;; XExpr utilities
(provide xexpr-case)
(module+ test (require rackunit))
(require racket/match)
(define (xexpr-case x content element)
(match x
[(? string? s) (content s)]
[(list tag (list (list key value) ...) body ...) (element tag (map list key value) body)]
[(list tag body ...) (element tag '() body)]
[else (error 'xexpr-case "Invalid xexpr: ~a" x)]))
(module+ test
(define (x xexpr) (xexpr-case xexpr values list))
(check-equal? (x "hello") "hello")
(check-equal? (x `(a)) (list 'a '() '()))
(check-equal? (x `(a ())) (list 'a '() '()))
(check-equal? (x `(a ((href "hello")))) (list 'a '((href "hello")) '()))
(check-equal? (x `(a ((href "hello") (class "foo"))))
(list 'a '((href "hello") (class "foo")) '()))
(check-equal? (x `(div "content" (b "bold")))
(list 'div '() '("content" (b "bold"))))
(check-equal? (x `(div () "content" (b "bold")))
(list 'div '() '("content" (b "bold"))))
(check-equal? (x `(div ((id "hello")) "content" (b "bold")))
(list 'div '((id "hello")) '("content" (b "bold"))))
(check-equal? (x `(div ((id "hello") (class "foo")) "content" (b "bold")))
(list 'div '((id "hello") (class "foo")) '("content" (b "bold"))))
)