source: project/release/4/chickadee/trunk/chickadee.scm @ 25601

Last change on this file since 25601 was 25601, checked in by Jim Ursetto, 9 years ago

chickadee 0.9.11: Improve response time & Firefox rendering with <script> at end; fix TOC flash

Move <script>s to end of HTML, improving responsiveness, avoiding starting mid-page
in Firefox, and correcting flash of unhidden TOC. Introduce js/no-js class into
<html> a la Modernizr, though we do it with a one-line inline script.

File size: 24.5 KB
Line 
1;; chickadee chicken-doc server
2;; Copyright (c) 2010 Jim Ursetto.  All Rights Reserved.
3;; License: BSD.
4
5(module chickadee
6 (chickadee-start-server
7  cdoc-uri
8  chickadee-uri
9  incremental-search-uri
10  chickadee-css-files
11  chickadee-js-files
12  maximum-match-results
13  maximum-match-signatures
14  incremental-search
15  incremental-search-delay
16  cache-nodes-for
17  cache-static-content-for
18  last-modified
19  ajax-log
20
21  %chickadee:debug-incremental-search-latency
22  )
23
24(import scheme chicken)
25(import tcp data-structures srfi-1)
26(use spiffy-request-vars chicken-doc)
27(use spiffy)
28(use matchable)
29(use (only uri-generic uri-encode-string))
30(use uri-common)
31(use intarweb)
32;(load "chicken-doc-html.scm")
33(use chicken-doc-html)
34(use (only chicken-doc-admin man-filename->path))
35(use regex) (import irregex)
36(use (only srfi-13 string-index string-concatenate))
37(use (only posix seconds->string seconds->utc-time utc-time->seconds))
38(use srfi-18)
39(use (only sxml-transforms
40           pre-post-order* universal-conversion-rules* SRV:send-reply))
41
42;;; HTML
43
44(use (only ports with-output-to-port with-output-to-string))
45(define (sxml->html doc #!optional port)
46  (let* ((rules `((lit *preorder* . ,(lambda (t b) b))
47                  . ,universal-conversion-rules*))
48         (reply (lambda () (SRV:send-reply (pre-post-order* doc rules)))))
49    (if port
50        (with-output-to-port port reply)
51        (with-output-to-string reply))))
52
53(define (maybe pred x)
54  (if pred x '()))
55
56(define (charset c)
57  (maybe c
58         `(meta (@ (http-equiv "content-type")
59                   (content "text/html; charset=" ,c)))))
60(define (javascript u)
61  `(script (@ (type "text/javascript")
62              (src ,(uri->string u)))))
63(define (css-link u)
64  `(link (@ (rel stylesheet)
65            (href ,(uri->string u))
66            (type "text/css"))))
67
68;;; Pages
69
70(define (search-form)
71  `(form (@ (class "lookup")
72            (action ,(cdoc-page-path))
73            (method get))
74         (input (@ (id "searchbox")
75                   (class "text incsearch { "
76                     "url: \"" ,(uri->string (incremental-search-uri)) "\","
77                     "delay: " ,(incremental-search-delay)
78                     " }")
79                   (type text)
80                   (name q)
81                   (autocomplete off) ;; apparently readonly in DOM
82                   (autocorrect off)
83                   (autocapitalize off)) ;; iphone/ipad
84                )
85         (div (@ (class "buttons"))
86              (input (@ (class "button") (type submit)
87                        (id "query-name") (name "query-name")
88                        (value "Lookup")))
89              (input (@ (class "button") (type submit)
90                        (id "query-regex") (name "query-regex")
91                        (value "Regex"))))))
92
93(define (format-id x)
94  (match (match-nodes x)
95         ((n1)
96          (redirect-to (path->href (node-path n1))))
97         (()
98          ;; Should we return 404 here?  This is not a real resource
99          (node-page '()
100                     '()
101                     `(p "No node found matching identifier " (tt ,x))
102                     page-title: "node not found"))
103         (nodes
104          (match-page nodes x))))
105
106(define (format-re x)
107  (match-page (match-nodes (irregex x)) x))
108(define (format-path-re x)
109  (match-page (match-node-paths/re (irregex x)) x))
110
111(define (match-page nodes match-text)
112  (let ((max-results (maximum-match-results))
113        (result-length (length nodes)))
114    (cache-for
115     (cache-nodes-for) ;?
116     (lambda ()
117       (last-modified-at
118        (max (repository-modification-time (current-repository))
119             (last-modified))
120        (lambda ()
121          (node-page
122           `("query " ,match-text " ("
123             ,(maybe (> result-length max-results)
124                     `(,max-results " of "))
125             ,result-length " matches)")
126           '()                 ;contents
127           (if (= result-length 0)
128               '()
129               `(table
130                 (@ (class "match-results"))
131                 (tr (th "path") (th "signature"))
132                 ,(let loop ((sigs (maximum-match-signatures))
133                             (results max-results)
134                             (nodes nodes) (acc '()))
135                    (if (or (null? nodes)
136                            (<= results 0))
137                        (reverse acc)
138                        (let ((n (car nodes)))
139                          (loop (- sigs 1) (- results 1)
140                                (cdr nodes)
141                                (cons
142                                 `(tr
143                                   (td (@ (class "match-path"))
144                                       ,(title-path n))
145                                   (td (@ (class "match-sig"))
146                                       ,(path-link
147                                         (node-path n)
148                                         (if (<= sigs 0)
149                                             "-"
150                                             `(tt ,(node-signature n))))))
151                                 acc)))))))
152           page-title: "query results")))))))
153
154(define (contents-list n)
155  (let ((ids (node-child-ids n)))
156    (if (null? ids)
157        '()
158        `((h2 (@ (class "contents-list"))
159              "Contents " (& "raquo"))
160          (ul (@ (class "contents-list"))
161              ,(map
162                (let ((child->href (make-child->href n)))
163                  (lambda (id)
164                    `(li
165                      (a (@ (href ,(child->href id))) ,id))))
166                (map ->string ids)))))))
167
168(define (format-path p)
169  (let ((n (handle-exceptions e #f (lookup-node (string-split p)))))
170    (if n
171        (cache-for   ;; NB We send cache-control even with 304s.
172         (cache-nodes-for)
173         (lambda ()
174           (last-modified-at
175            ;; Node modification time may also be more fine-grained,
176            ;; but some generated HTML may depend on the entire repository
177            ;; anyway--and we usually update the whole repo at once.
178            (max (repository-modification-time (current-repository))
179                 (last-modified))
180            (lambda ()
181              (if (null? (node-path n))
182                  (node-page '()
183                             (contents-list n)
184                             (root-page))
185                  (node-page (title-path n)
186                             (contents-list n)
187                             `(lit
188                               . ,(chicken-doc-sxml->html (node-sxml n)
189                                                          path->href
190                                                          (make-def->href n)
191                                                          man-filename->path))
192                             page-title: (last (node-path n))))))))
193        (node-not-found p `(p "No node found at path " (i ,p))))))
194
195(define (path->href p)             ; FIXME: use uri-relative-to, etc
196  (string-append
197   (chickadee-page-path)
198   "/"
199   (string-intersperse (map (lambda (x)
200                              (uri-encode-string (->string x)))
201                            p) "/")))
202;; Given a node N, return a procedure that will produce
203;; an href for any child node ID of N.  Although simple now,
204;; this could be extended to use relative paths when the current
205;; URI permits it, saving some bandwidth.
206(define (make-child->href n)
207  (let ((path (node-path n)))
208    (lambda (id)
209      (if (node-definition-id? n id)
210          (string-append "#" (quote-identifier (definition->identifier id)))
211          (path->href (append path (list id)))))))
212
213;; FIXME??? chg "identifier" to html-id (or maybe, fragment to html-id)
214
215;; Given a node N, return a procedure that will produce a definition href
216;; for ID suitable for placement in a defsig in N.  That is, it will refer
217;; to the actual child node when N is an egg (etc.) and it will refer to
218;; an anchor id in the parent when N is itself a defsig.
219(define (make-def->href n)
220  (let ((doc (node-sxml n))
221        (path (node-path n)))
222    (if (eq? (car doc) 'def)
223        (let* ((path (butlast path))
224               (href (path->href path)))
225          (lambda (id)
226            (string-append href "#" (quote-identifier (definition->identifier id)))))
227        (lambda (id)
228          (path->href (append path (list id)))))))
229
230(define (title-path n)
231  (define (links n)
232    (let loop ((p (node-path n))
233               (f '())
234               (r '()))
235      (if (null? p)
236          (reverse r)
237          (let* ((id (->string (car p)))
238                 (f (append f (list id)))
239                 (n (lookup-node f)))
240            (loop (cdr p) f (cons (path-link f id) r))))))
241 
242  (intersperse (links n)
243               '(" " (& "raquo") " "))) ;; literal " &raquo; " would be nicer
244
245(define (query p)
246  (let ((q (string-split p)))
247    (cond ((null? q)
248           (redirect-to (cdoc-page-path)))
249          ((null? (cdr q))
250           (format-id p))
251          (else
252           (redirect-to (path->href q))
253           ;; (format-path p)
254           ))))                 ;  API defect
255
256(define (incremental-search-handler _)
257  (with-request-vars*
258   $ (q)
259   ;; FIXME: doesn't skip 0 or #f incremental-search
260   (let ((M (vector->list
261             ((if (string-index q #\space)
262                  match-paths/prefix
263                  match-ids/prefix)
264              q (incremental-search)))))
265     (let ((body (if (null? M)
266                     ""
267                     (let ((plen (string-length q)))
268                       (tree->string
269                        `("<ul>"
270                          ,(map (lambda (x)
271                                  `("<li>"
272                                    "<b>" ,(htmlize (substring x 0 plen))
273                                    "</b>"
274                                    ,(htmlize (substring x plen)) "</li>"))
275                                M)
276                          "</ul>"))))))
277       ;; Latency pause for debugging
278       (let ((pause (%chickadee:debug-incremental-search-latency)))
279         (if (> pause 0)
280             (thread-sleep! (/ pause 1000))))
281       ;; Send last-modified headers? May not be worth it.
282       (cache-privately-for  ; `private` has no effect on nginx proxy cache
283        (cache-nodes-for)
284        (lambda ()
285          (parameterize ((access-log (ajax-log))) ; Logging is extremely slow
286            (send-response body: body))))))))
287
288;; Re matching, it might be more useful to match against each identifier level
289;; with a separate regex.
290
291(define (root-page)
292  `((h3 "Search Chicken documentation")
293    ,(search-form)
294    (p "Enter a documentation node name or path in the search box above.")
295    (ul (li "A node name is an identifier, egg, module or unit name, such as "
296            (i "open/rdonly") ", " (i "awful") ", "
297            (i "scheme") " or " (i "eval") ".")
298        (li "A node path is a sequence of node names, such as "
299            (i "eval load") " or " (i "foreign types") ".")
300        (li "Regular expression matching is usually done against node names,"
301            " but if a space is present, the full node path will be considered."))
302    (h3 "Quick links")
303    (ul (li ,(path-link '(chicken) "Chicken manual"))
304        (li ,(path-link '(chicken language) "Supported language"))
305        (li ,(path-link '(foreign) "FFI")))
306    (h4 "About")
307    (p ,(path-link '(chickadee))
308       " is the web interface to the "
309       ,(path-link '(chicken-doc))
310       " documentation system for the "
311       (a (@ (href "http://call-cc.org")) "Chicken")
312       " language.  It is running on the "
313       ,(path-link '(spiffy))
314       " webserver on Chicken " ,(chicken-version) ".")))
315
316;; Warning: TITLE, CONTENTS and BODY are expected to be HTML-quoted.
317;; Internal fxn for node-page / not-found
318(define (%node-page-body title contents body #!key (page-title #f))
319  (sxml->html
320   `((lit "<!doctype html>")
321     (html (@ class "no-js")
322      (head ,(charset "utf-8")
323            ,(map css-link (chickadee-css-files))
324            ;; Remove "no-js" class and add "js" class to <HTML> when JS enabled, a la Modernizr.
325            (script "this.document.documentElement.className = "
326                    "this.document.documentElement.className.replace(/\\bno-js\\b/, '') + ' js '")
327            (title ,(if page-title
328                        `(,page-title " | chickadee")
329                        "chickadee server"))
330            (meta (@ (name "viewport")
331                     (content "initial-scale=1"))))
332      (body
333       (p (@ (id "navskip"))
334          (a (@ (href "#body")) "Skip navigation."))
335       (div (@ (id "hdr"))
336            (h1 ,(path-link '() "chickadee")
337                ,(if (null? title)
338                     `((" | " ,(path-link '(chicken-doc))
339                        " server"))
340                     `((lit " &raquo; ") ,title)))
341            (h5 (label (@ (for "hdr-searchbox"))
342                       "Identifier search"))
343            (form (@ (id "hdr-lookup")
344                     (class "hdr-lookup")
345                     (action ,(cdoc-page-path))
346                     (method "get"))
347                  (input (@ (id "hdr-searchbox")
348                            (name "q")
349                            (class "text incsearch { "
350                              "url: \"" ,(uri->string (incremental-search-uri)) "\","
351                              "delay: " ,(incremental-search-delay) " }")
352                            (type "text")
353                            (accesskey "f")
354                            (title "chickadee search (Ctrl-F)")
355                            (autocomplete "off")
356                            (autocorrect "off")
357                            (autocapitalize "off")
358                            (tabindex "1")))
359                  (button (@ (id "hdr-submit") (name "query-name")
360                             (title "Search chicken-doc for this identifier")
361                             (class "button") (type "submit"))
362                          (& "nbsp"))))
363       ,(maybe (not (null? contents))
364               `(div (@ (id "contents"))
365                     ,contents))
366       (div (@ (id "body"))
367            (div (@ (id "main"))
368                 ,body)))
369      ,(map javascript (chickadee-js-files))))))
370
371(define (node-page title contents body #!key (page-title #f))
372  (send-response
373   body: (%node-page-body title
374                          contents
375                          body
376                          page-title: page-title)
377   headers: `((content-type #(text/html ((charset . "utf-8"))))
378              )))
379
380(define (node-not-found title body)
381  ;; Should create a dedicated not-found page instead;
382  ;; but right now I don't want to duplicate main page code
383  (send-response code: 404 reason: "Not found"
384                 body:
385                 (%node-page-body title
386                                  '()
387                                  body
388                                  page-title: "node not found")))
389
390(define cdoc-page-path (make-parameter #f)) ; cached -- probably not necessary
391(define cdoc-uri
392  (make-parameter (uri-reference "/cdoc")
393                  (lambda (x)
394                    (cdoc-page-path
395                     (and x (uri->string x)))
396                    x)))
397(define incremental-search-uri
398  (make-parameter (uri-reference "/cdoc/ajax/prefix")))
399(define incremental-search-delay     ; time in MS to delay incremental search requests
400  (make-parameter 50))
401
402(define chickadee-page-path (make-parameter #f)) ; cached -- probably not necessary
403(define chickadee-uri
404  (make-parameter (uri-reference "/chickadee")
405                  (lambda (x)
406                    (chickadee-page-path   ;auto update (mostly for debugging)
407                     (and x (uri->string x)))
408                    x)))
409
410(define chickadee-css-files
411  (make-parameter (list (uri-reference "/cdoc/chickadee.css"))))
412(define chickadee-js-files
413  (make-parameter (list (uri-reference "/cdoc/chickadee.js"))))
414
415(define maximum-match-results (make-parameter 250))
416(define maximum-match-signatures (make-parameter 100))
417(define cache-nodes-for (make-parameter 300))
418(define cache-static-content-for (make-parameter 3600))
419;; Base time used for last-modified calculations, in seconds.
420;; Set to (current)-seconds to invalidate pages when server is started.
421(define last-modified (make-parameter 0))
422;; Number of incremental search results to display; 0 or #f to disable.
423(define incremental-search (make-parameter 0))
424(define ajax-log (make-parameter #f)) ;; AJAX access log.  #f to disable.
425
426;; debugging: incremental search latency, in ms
427(define %chickadee:debug-incremental-search-latency (make-parameter 0))
428
429;;; Helper functions
430
431;; Inefficient way to functionally update an alist.
432(define (alist-update k v x . test)
433  (apply alist-update! k v (alist-copy x) test))
434(define (update-param param val uri-query)
435  (alist-update param val uri-query))
436(define (update-request-uri r u)
437  (make-request uri: u
438                ;; No easy way to update request URI.
439                port: (request-port r)
440                method: (request-method r)
441                major: (request-major r)
442                minor: (request-minor r)
443                headers: (request-headers r)))
444(define (match-path pattern path)  ; just a prefix match on list; returns remainder
445  (let loop ((pattern pattern)
446             (path path))
447    (cond ((null? path)
448           (and (null? pattern)
449                path))
450          ((null? pattern)
451           path)
452          ((equal? (car pattern)
453                   (car path))                              ; allow re match?
454           (loop (cdr pattern) (cdr path)))
455          (else #f))))
456;; calls rewriter with the current uri; restarts request with the returned uri
457(define (rewrite-uri rewriter)
458  (let* ((r (current-request))
459         (u (request-uri r)))
460    (restart-request
461     (update-request-uri r (rewriter u)))))
462
463(define (link href desc)
464  `(a (@ (href ,href)) ,desc))
465(define (path-link path #!optional desc)
466  (link (path->href path)
467        (or desc (string-intersperse (map ->string path) " "))))
468
469(define ($ var #!optional converter/default)  ; from awful
470    ((http-request-variables) var converter/default))
471(define http-request-variables (make-parameter #f))
472
473;; note: missing full node path should maybe generate 404
474(define (redirect-to path #!key (code 302) (reason "Found") (headers '()))
475  (send-response code: code
476                 reason: reason
477                 headers: `((location ,(uri-relative-to
478                                        (uri-reference path)
479                                        (request-uri (current-request)) ;; spiffy 4.8
480                                        )))))
481
482;; Return 304 Not Modified.  If ACTUAL-MTIME is an integer, it is
483;; returned to the client as the actual modification time of the resource.
484;; You should also resend any associated Cache-control: directive (separately).
485(define (not-modified actual-mtime)
486  (let ((headers (if (integer? actual-mtime)     ; error?
487                     `((last-modified #(,(seconds->utc-time actual-mtime))))
488                     '())))
489    (send-response code: 304 reason: "Not modified" headers: headers)))
490
491;; Compare mtime with If-Modified-Since: header in client request.
492;; If newer, client's copy of resource is outdated and we execute thunk.
493;; Otherwise, return 304 Not Modified.
494(define (last-modified-at mtime thunk)
495  (let ((header-mtime-vec (header-value
496                           'if-modified-since
497                           (request-headers (current-request)))))
498    (if (or (not header-mtime-vec)
499            (> mtime (utc-time->seconds header-mtime-vec)))
500        (with-headers `((last-modified #(,(seconds->utc-time mtime))))
501                      thunk)
502        (not-modified mtime))))
503
504;; SECONDS: number of seconds to cache for; or #t to set a far-future
505;; expiration date (1 year as per RFC); or #f to force no caching.
506(define (cache-for seconds thunk)
507  (if (not seconds)
508      (with-headers `((cache-control (max-age . 0)   ; use "no-cache" ?
509                                     (must-revalidate . #t))) thunk)
510      (let ((seconds (if (integer? seconds)
511                         (min seconds 31536000)
512                         31536000)))
513        (with-headers `((cache-control (max-age . ,seconds))) thunk))))
514(define (cache-privately-for seconds thunk)
515  (if (not seconds)
516      (with-headers `((x-accel-expires 0)  ; nginx hack
517                      (cache-control (max-age . 0)
518                                     (must-revalidate . #t)
519                                     (private . #t))))
520      (let ((seconds (if (integer? seconds)
521                         (min seconds 31536000)
522                         31536000)))
523        (with-headers `((x-accel-expires 0) ; nginx hack
524                        (cache-control (private . #t)
525                                       (max-age . ,seconds)))
526                      thunk))))
527
528;; (define (uri-path->string p)   ; (/ "foo" "bar") -> "/foo/bar"
529;;   (uri->string (update-uri (uri-reference "")
530;;                            path: p)))
531
532(define (proxy-logger)
533  ;; access logger with X-Forwarded-For: header
534  ;; Copied verbatim from spiffy's handle-access-logging
535  (let ((h (request-headers (current-request))))
536    (log-to (access-log)
537            "~A ~A [~A] \"~A ~A HTTP/~A.~A\" ~A \"~A\" \"~A\""
538            (header-value 'x-forwarded-for h "-")
539            (remote-address)
540            (seconds->string (current-seconds))
541            (request-method (current-request))
542            (uri->string (request-uri (current-request)))
543            (request-major (current-request))
544            (request-minor (current-request))
545            (response-code (current-response))
546            (uri->string (header-value 'referer h (uri-reference "-")))
547            (let ((product (header-contents 'user-agent h)))
548              (if product
549                  (product-unparser product)   ; undocumented intarweb proc
550                  "**Unknown product**")))))
551
552;;;
553
554(define (rewrite-chickadee-uri u p)
555  (let ((q (uri-query u)))
556    (update-uri u
557                path: (uri-path (cdoc-uri))
558                query: (if (null? p)
559                           q
560                           (update-param 'path
561                                         (string-intersperse p " ") q)))))
562
563(define (chickadee-handler p)
564  (rewrite-uri (lambda (u) (rewrite-chickadee-uri u p)))) ;?
565
566(define (cdoc-handler p)
567  p ;ignore
568  (with-request-vars*
569   $ (id path q)
570     (cond (path => format-path)
571           (id   => format-id)
572           (q    => (lambda (p)
573                      (with-request-vars*
574                       $ (query-regex query-name)
575                       (if query-regex
576                           (if (string-index p #\space) ; hmm
577                               (format-path-re p)
578                               (format-re p))
579                           (query p)))))
580           (else (format-path "")))))
581
582;;; handlers
583
584;; vhost-map can be used to take control of requests as
585;; they come in, before any handlers are invoked.
586
587(define +vhost-map+
588  `((".*" . ,(lambda (continue)
589               (let ((p (uri-path (request-uri (current-request)))))
590                 (parameterize ((http-request-variables (request-vars))) ; for $
591                   (cond ((equal? (uri-path (cdoc-uri)) p)
592                          => cdoc-handler)
593                         ((match-path (uri-path (chickadee-uri)) p)
594                          => chickadee-handler)
595                         ((and (incremental-search-uri)
596                               (equal? (uri-path (incremental-search-uri)) p))
597                          => incremental-search-handler)
598                         ;; Last resort redirect of root path to main page.
599                         ((equal? p '(/ ""))
600                          (redirect-to (path->href '())))
601                         (else
602                          (continue)))))))))
603
604(define +not-found-handler+
605 (let ((old-handler (handle-not-found)))  ; hmm
606   (lambda (path) ; useless
607     (old-handler path))))
608
609(define +static-file-handler+
610  (let ((old-handler (handle-file)))
611    (lambda (path)
612      (cache-for (cache-static-content-for)
613                 (lambda ()
614                   (old-handler path))))))
615
616;;; start server
617
618(define (chickadee-start-server)
619  (verify-repository)
620  ;; using parameterize, we cannot override in REPL
621  (parameterize ((vhost-map +vhost-map+)
622                 (handle-not-found +not-found-handler+)
623                 (handle-file +static-file-handler+)
624                 (handle-access-logging proxy-logger)
625                 (tcp-buffer-size 1024)
626                 (mime-type-map
627                  `(("js" . application/x-javascript)  ;; spiffy has subpar mime-type
628                    . ,(mime-type-map))))
629    (start-server))))
630
631;; time echo "GET /cdoc?q=p&query-regex=Regex HTTP/1.0" | nc localhost 8080 >/dev/null
632;; (1374 matches) real    0m1.382s (warm cache)
633;;                real    0m1.098s (turn signatures off)
Note: See TracBrowser for help on using the repository browser.