aed4f6a063
Also, change local mode to use absolute "file://" references across sites (makes "doc-site.js" plus "doc-site.css" work locally) and add "index.html" to paths a needed, but add a `-r` relative mode for the old behavior.
341 lines
14 KiB
Racket
341 lines
14 KiB
Racket
#lang at-exp racket/base
|
|
|
|
(require scribble/html racket/dict (for-syntax racket/base syntax/name syntax/parse)
|
|
"utils.rkt" "resources.rkt" "private/roots.rkt")
|
|
|
|
(provide page page*
|
|
plain plain*
|
|
copyfile
|
|
symlink
|
|
(rename-out [mk-site site])
|
|
site?
|
|
site-dir
|
|
site-css-path
|
|
site-favicon-path
|
|
site-navbar
|
|
site-navbar-dynamic-js)
|
|
|
|
(define-for-syntax (process-contents who layouter stx xs)
|
|
(let loop ([xs xs] [kws '()] [id? #f])
|
|
(syntax-case xs ()
|
|
[(k v . xs) (keyword? (syntax-e #'k))
|
|
(loop #'xs (list* #'v #'k kws) (or id? (eq? '#:id (syntax-e #'k))))]
|
|
[_ (with-syntax ([layouter layouter]
|
|
[(x ...) (reverse kws)]
|
|
[(id ...)
|
|
(if id?
|
|
'()
|
|
(let ([name (or (syntax-property stx 'inferred-name)
|
|
(syntax-local-name))])
|
|
(if name (list '#:id `',name) '())))]
|
|
;; delay body, allow definitions
|
|
[body #`(λ () (begin/text #,@xs))])
|
|
#'(layouter id ... x ... body))])))
|
|
|
|
(define (get-path who id file sfx dir)
|
|
(define file*
|
|
(or file
|
|
(let ([f (and id (symbol->string (force id)))])
|
|
(cond [(and f (regexp-match #rx"[.]" f)) f]
|
|
[(and f sfx)
|
|
(string-append f (regexp-replace #rx"^[.]?" sfx "."))]
|
|
[else (error who "missing `#:file', or `#:id'~a"
|
|
(if sfx "" " and `#:suffix'"))]))))
|
|
(if dir (web-path dir file*) file*))
|
|
|
|
;; The following are not intended for direct use, see
|
|
;; `define+provide-context' below (it could be used with #f for the
|
|
;; directory if this ever gets used for a flat single directory web
|
|
;; page.)
|
|
|
|
;; for plain text files
|
|
(define-syntax (plain stx)
|
|
(syntax-case stx () [(_ . xs) (process-contents 'plain #'plain* stx #'xs)]))
|
|
(define (plain* #:site site
|
|
#:id [id #f] #:suffix [suffix #f]
|
|
#:file [file #f]
|
|
#:referrer [referrer values]
|
|
#:newline [newline? #t]
|
|
content)
|
|
(resource/referrer (get-path 'plain id file suffix (site-dir site))
|
|
(file-writer output (list content (and newline? "\n")))
|
|
referrer))
|
|
|
|
;; page layout function
|
|
(define-syntax (page stx)
|
|
(syntax-case stx () [(_ . xs) (process-contents 'page #'page* stx #'xs)]))
|
|
(define (page* #:site site
|
|
#:id [id #f]
|
|
#:file [file #f]
|
|
;; if this is true, return only the html -- don't create
|
|
;; a resource -- therefore no file is made, and no links
|
|
;; to it can be made (useful only for stub templates)
|
|
#:html-only [html-only? #f]
|
|
#:title [label (if id
|
|
(let* ([id (format "~a" (force id))]
|
|
[id (regexp-replace #rx"^.*/" id "")]
|
|
[id (regexp-replace #rx"-" id " ")])
|
|
(string-titlecase id))
|
|
(error 'page "missing `#:id' or `#:title'"))]
|
|
#:link-title [linktitle label]
|
|
#:window-title [wintitle @list{Racket: @label}]
|
|
;; can be #f (default), 'full: full page (and no div),
|
|
;; otherwise, a css width
|
|
#:width [width #f]
|
|
#:description [description #f] ; for a meta tag
|
|
#:extra-headers [extra-headers #f]
|
|
#:extra-body-attrs [body-attrs #f]
|
|
#:referrer [referrer
|
|
(λ (url . more)
|
|
(a href: url (if (null? more) linktitle more)))]
|
|
;; will be used instead of `this' to determine navbar highlights
|
|
#:part-of [part-of #f]
|
|
content0)
|
|
(define dir (site-dir site))
|
|
(define (page)
|
|
(define desc
|
|
(and description (meta name: 'description content: description)))
|
|
(define resources (site-resources site))
|
|
(define header
|
|
(let ([headers (resources 'headers)]
|
|
[extras (if (and extra-headers desc)
|
|
(list desc "\n" extra-headers)
|
|
(or desc extra-headers))])
|
|
(if extras (list headers "\n" extras) headers)))
|
|
(define navbar ((resources 'make-navbar) (or part-of this)))
|
|
(define content
|
|
(list navbar "\n"
|
|
(case width
|
|
[(full) content0]
|
|
[(#f) (div class: 'bodycontent content0)]
|
|
[else (div class: 'bodycontent style: @list{width: @|width|@";"}
|
|
content0)])
|
|
(resources 'postamble)))
|
|
@list{@resources['preamble]
|
|
@html{@||
|
|
@head{@||
|
|
@title{@wintitle}
|
|
@header
|
|
@||}
|
|
@(if body-attrs
|
|
(apply body `(,@body-attrs ,content))
|
|
(body content))}
|
|
@||})
|
|
(define this (and (not html-only?)
|
|
(resource/referrer (get-path 'page id file "html" dir)
|
|
(file-writer output-xml page)
|
|
referrer)))
|
|
(when this (pages->part-of this (or part-of this)))
|
|
(or this page))
|
|
|
|
;; maps pages to their parts, so symbolic values can be used to determine it
|
|
(define pages->part-of
|
|
(let ([t (make-hasheq)])
|
|
(case-lambda [(page) (hash-ref t page page)]
|
|
[(page part-of) (hash-set! t page part-of)])))
|
|
|
|
(define (list-ref* l n d)
|
|
(if ((length l) . > . n)
|
|
(list-ref l n)
|
|
d))
|
|
|
|
(define ((navbar-content logo columns page-style?))
|
|
(define (icon name) @i[class: name]{})
|
|
(define (row . content) (apply div class: "row" content))
|
|
(define main-promise (resource "www/" #f))
|
|
@row{
|
|
@(if page-style?
|
|
@a[class: "toggle" gumby-trigger: "#nav1 > .row > ul" href: "#"]{
|
|
@icon{icon-menu}}
|
|
'())
|
|
@a[class: "five columns logo" href: (url-of main-promise)]{
|
|
@img[class: "logo" src: logo width: "198" height: "60" alt: "Racket"]}
|
|
@ul[class: "five columns"]{
|
|
@li{@(list-ref* columns 0 "")}
|
|
@li{@(list-ref* columns 1 "")}
|
|
@li{@(list-ref* columns 2 "")}
|
|
@li{@(list-ref* columns 3 "")}}})
|
|
|
|
(define ((navbar-maker logo columns page-style?) this)
|
|
@div[class: "navbar gumby-content" gumby-fixed: "top" id: "nav1"]{
|
|
@((navbar-content logo columns page-style?))})
|
|
|
|
(define gumby-preamble
|
|
@list{
|
|
@; paulirish.com/2008/conditional-stylesheets-vs-css-hacks-answer-neither/
|
|
@comment{[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]}
|
|
@comment{[if IE 7]> <html class="no-js ie7 oldie" lang="en"> <![endif]}
|
|
@comment{[if IE 8]> <html class="no-js ie8 oldie" lang="en"> <![endif]}
|
|
@comment{[if IE 9]> <html class="no-js ie9" lang="en"> <![endif]}
|
|
@comment{[if gt IE 9]><!--> <html class="no-js" lang="en" @;
|
|
itemscope itemtype="http://schema.org/Product"> <!--<![endif]}
|
|
})
|
|
|
|
(define (make-gumby-postamble resources)
|
|
@list{
|
|
@||
|
|
@; Grab Google CDN's jQuery, with a protocol relative URL;
|
|
@; fall back to local if offline
|
|
@script[src: '("http://ajax.googleapis.com/"
|
|
"ajax/libs/jquery/1.9.1/jquery.min.js")]
|
|
@script/inline{
|
|
window.jQuery || document.write(@;
|
|
'<script src=@(resources "jquery-1.9.1.min.js")><\/script>')}
|
|
@script[src: (resources "gumby.min.js")]
|
|
@script[src: (resources "plugins.js")]
|
|
@script[src: (resources "main.js")]
|
|
@||
|
|
})
|
|
|
|
(define (html-icon-headers icon)
|
|
@; Place favicon.ico and apple-touch-icon.png in the root
|
|
@; directory: mathiasbynens.be/notes/touch-icons
|
|
@list{@link[rel: "icon" href: icon type: "image/ico"]
|
|
@link[rel: "shortcut icon" href: icon type: "image/x-icon"]})
|
|
|
|
(define (html-headers resources favicon page-style?)
|
|
@list{
|
|
@meta[name: "generator" content: "Racket"]
|
|
@meta[http-equiv: "Content-Type" content: "text/html; charset=utf-8"]
|
|
@meta[charset: "utf-8"]
|
|
@; Use the .htaccess and remove this line to avoid edge case issues.
|
|
@; More info: h5bp.com/b/378
|
|
@meta[http-equiv: "X-UA-Compatible" content: "IE=edge,chrome=1"]
|
|
@favicon
|
|
@; Mobile viewport optimized: j.mp/bplateviewport
|
|
@meta[name: "viewport"
|
|
content: "width=device-width, initial-scale=1.0, maximum-scale=1"]
|
|
@; CSS: implied media=all
|
|
@; CSS concatenated and minified via ant build script
|
|
@; @link[rel: "stylesheet" href="css/minified.css"]
|
|
@; CSS imports non-minified for staging, minify before moving to
|
|
@; production
|
|
@link[rel: "stylesheet" href: (resources 'style-path)]
|
|
@; TODO: Edit the `more.css' definition in www/index.rkt
|
|
@; More ideas for your <head> here: h5bp.com/d/head-Tips
|
|
@; All JavaScript at the bottom, except for Modernizr / Respond.
|
|
@; Modernizr enables HTML5 elements & feature detects; Respond is
|
|
@; a polyfill for min/max-width CSS3 Media Queries
|
|
@; For optimal performance, use a custom Modernizr build:
|
|
@; www.modernizr.com/download/
|
|
@(if page-style?
|
|
@script[src: (resources "modernizr-2.6.2.min.js")]
|
|
null)
|
|
})
|
|
|
|
(define (make-resources files navigation page-style? sharing-site)
|
|
(define (recur/share what)
|
|
(if sharing-site
|
|
((site-resources sharing-site) what)
|
|
(resources what)))
|
|
(define (resources what)
|
|
(case what
|
|
;; composite resources
|
|
[(page-style?) page-style?]
|
|
[(preamble) preamble]
|
|
[(postamble) postamble]
|
|
[(headers) headers]
|
|
[(make-navbar) make-navbar] ; page -> navbar
|
|
[(make-navbar-content) make-navbar-content] ; -> outputable
|
|
[(icon-headers) icon-headers]
|
|
;; aliases for specific resource files
|
|
[(style-path) (recur/share
|
|
(if page-style?
|
|
"gumby.css"
|
|
"gumby-slice.css"))]
|
|
[(logo-path) (recur/share "logo-and-text.png")]
|
|
[(icon-path) (and page-style?
|
|
(recur/share "plticon.ico"))]
|
|
;; get a resource file path
|
|
[else (cond [(assoc what files)
|
|
;; delay the `url-of' until we're in the rendering context
|
|
=> (λ(f) (λ() (url-of (cadr f))))]
|
|
[sharing-site (recur/share what)]
|
|
[else (error 'resource "unknown resource: ~e" what)])]))
|
|
(define icon-headers (html-icon-headers (resources 'icon-path)))
|
|
(define headers (html-headers resources icon-headers page-style?))
|
|
(define make-navbar (navbar-maker (resources 'logo-path) navigation page-style?))
|
|
(define make-navbar-content (navbar-content (resources 'logo-path) navigation page-style?))
|
|
(define preamble (cons @doctype['html]
|
|
(if page-style? gumby-preamble null)))
|
|
(define postamble (if page-style? (make-gumby-postamble resources) null))
|
|
resources)
|
|
|
|
(define (copyfile #:site site s [t (basename s)])
|
|
(copyfile-resource s t #:dir (site-dir site)))
|
|
(define (symlink #:site site s [t (basename s)])
|
|
(symlink-resource s t #:dir (site-dir site)))
|
|
|
|
(struct site (dir resources-promise)
|
|
#:constructor-name make-site)
|
|
|
|
(define (site-resources s)
|
|
(force (site-resources-promise s)))
|
|
|
|
(define mk-site
|
|
(let ([site
|
|
(lambda (dir
|
|
#:url [url #f]
|
|
#:always-abs-url? [abs-url? #f]
|
|
#:robots [robots #t]
|
|
#:htaccess [htaccess #t]
|
|
#:navigation [navigation null]
|
|
#:page-style? [page-style? #t]
|
|
#:meta? [meta? page-style?]
|
|
#:share-from [given-sharing-site #f])
|
|
(when url
|
|
(registered-url-roots (cons (list* dir
|
|
url
|
|
(if abs-url? '(abs) null))
|
|
(registered-url-roots))))
|
|
(define sharing-site
|
|
;; Can use given site only if it has enough relative to
|
|
;; this one:
|
|
(and given-sharing-site
|
|
(or ((site-resources given-sharing-site) 'page-style?)
|
|
(not page-style?))
|
|
given-sharing-site))
|
|
(define the-site
|
|
(make-site dir (delay
|
|
(make-resources
|
|
(make-resource-files
|
|
(λ (id . content)
|
|
(page* #:id id
|
|
#:site the-site
|
|
content))
|
|
dir robots htaccess
|
|
(or page-style?
|
|
(pair? navigation))
|
|
meta?
|
|
(and sharing-site
|
|
#t))
|
|
navigation
|
|
page-style?
|
|
sharing-site))))
|
|
the-site)])
|
|
site))
|
|
|
|
(define (site-css-path s)
|
|
((site-resources s) 'style-path))
|
|
|
|
(define (site-favicon-path s)
|
|
((site-resources s) 'icon-path))
|
|
|
|
(define (site-navbar s)
|
|
(((site-resources s) 'make-navbar) #f))
|
|
|
|
(define (site-navbar-dynamic-js s)
|
|
(define xml (((site-resources s) 'make-navbar-content)))
|
|
@list{
|
|
function AddNavbarToBody() {
|
|
var body = document.getElementsByTagName("body")[0];
|
|
var h = document.createElement('div');
|
|
h.setAttribute("class", "navbar gumby-content");
|
|
h.innerHTML = @(let ([p (open-output-string)])
|
|
(output xml p)
|
|
(format "~s" (regexp-replace* #rx"\n +" (get-output-string p) "")));
|
|
body.insertBefore(h, body.firstChild);
|
|
}
|
|
})
|
|
|