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

Last change on this file since 21731 was 21731, checked in by Jim Ursetto, 10 years ago

chickadee: make man-filename->path a parameter to chicken-doc-html

Other changes:

  • Permit #f return in def->href to avoid making a link
  • remove star export introduced several versions ago
  • Shorten sxml->html a bit
  • bump trunk to 0.9.8.3
File size: 24.2 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
322      (head ,(charset "utf-8")
323            ,(map javascript (chickadee-js-files))
324            ,(map css-link (chickadee-css-files))
325            (title ,(if page-title
326                        `(,page-title " | chickadee")
327                        "chickadee server"))
328            (meta (@ (name "viewport")
329                     (content "initial-scale=1"))))
330      (body
331       (p (@ (id "navskip"))
332          (a (@ (href "#body")) "Skip navigation."))
333       (div (@ (id "hdr"))
334            (h1 ,(path-link '() "chickadee")
335                ,(if (null? title)
336                     `((" | " ,(path-link '(chicken-doc))
337                        " server"))
338                     `((lit " &raquo; ") ,title)))
339            (h5 (label (@ (for "hdr-searchbox"))
340                       "Identifier search"))
341            (form (@ (id "hdr-lookup")
342                     (class "hdr-lookup")
343                     (action ,(cdoc-page-path))
344                     (method "get"))
345                  (input (@ (id "hdr-searchbox")
346                            (name "q")
347                            (class "text incsearch { "
348                              "url: \"" ,(uri->string (incremental-search-uri)) "\","
349                              "delay: " ,(incremental-search-delay) " }")
350                            (type "text")
351                            (accesskey "f")
352                            (title "chickadee search (Ctrl-F)")
353                            (autocomplete "off")
354                            (autocorrect "off")
355                            (autocapitalize "off")
356                            (tabindex "1")))
357                  (button (@ (id "hdr-submit") (name "query-name")
358                             (title "Search chicken-doc for this identifier")
359                             (class "button") (type "submit"))
360                          (& "nbsp"))))
361       ,(maybe (not (null? contents))
362               `(div (@ (id "contents"))
363                     ,contents))
364       (div (@ (id "body"))
365            (div (@ (id "main"))
366                 ,body)))))))
367
368(define (node-page title contents body #!key (page-title #f))
369  (send-response
370   body: (%node-page-body title
371                          contents
372                          body
373                          page-title: page-title)
374   headers: `((content-type #(text/html ((charset . "utf-8"))))
375              )))
376
377(define (node-not-found title body)
378  ;; Should create a dedicated not-found page instead;
379  ;; but right now I don't want to duplicate main page code
380  (send-response code: 404 reason: "Not found"
381                 body:
382                 (%node-page-body title
383                                  '()
384                                  body
385                                  page-title: "node not found")))
386
387(define cdoc-page-path (make-parameter #f)) ; cached -- probably not necessary
388(define cdoc-uri
389  (make-parameter (uri-reference "/cdoc")
390                  (lambda (x)
391                    (cdoc-page-path
392                     (and x (uri->string x)))
393                    x)))
394(define incremental-search-uri
395  (make-parameter (uri-reference "/cdoc/ajax/prefix")))
396(define incremental-search-delay     ; time in MS to delay incremental search requests
397  (make-parameter 50))
398
399(define chickadee-page-path (make-parameter #f)) ; cached -- probably not necessary
400(define chickadee-uri
401  (make-parameter (uri-reference "/chickadee")
402                  (lambda (x)
403                    (chickadee-page-path   ;auto update (mostly for debugging)
404                     (and x (uri->string x)))
405                    x)))
406
407(define chickadee-css-files
408  (make-parameter (list (uri-reference "/cdoc/chickadee.css"))))
409(define chickadee-js-files
410  (make-parameter (list (uri-reference "/cdoc/chickadee.js"))))
411
412(define maximum-match-results (make-parameter 250))
413(define maximum-match-signatures (make-parameter 100))
414(define cache-nodes-for (make-parameter 300))
415(define cache-static-content-for (make-parameter 3600))
416;; Base time used for last-modified calculations, in seconds.
417;; Set to (current)-seconds to invalidate pages when server is started.
418(define last-modified (make-parameter 0))
419;; Number of incremental search results to display; 0 or #f to disable.
420(define incremental-search (make-parameter 0))
421(define ajax-log (make-parameter #f)) ;; AJAX access log.  #f to disable.
422
423;; debugging: incremental search latency, in ms
424(define %chickadee:debug-incremental-search-latency (make-parameter 0))
425
426;;; Helper functions
427
428;; Inefficient way to functionally update an alist.
429(define (alist-update k v x . test)
430  (apply alist-update! k v (alist-copy x) test))
431(define (update-param param val uri-query)
432  (alist-update param val uri-query))
433(define (update-request-uri r u)
434  (make-request uri: u
435                ;; No easy way to update request URI.
436                port: (request-port r)
437                method: (request-method r)
438                major: (request-major r)
439                minor: (request-minor r)
440                headers: (request-headers r)))
441(define (match-path pattern path)  ; just a prefix match on list; returns remainder
442  (let loop ((pattern pattern)
443             (path path))
444    (cond ((null? path)
445           (and (null? pattern)
446                path))
447          ((null? pattern)
448           path)
449          ((equal? (car pattern)
450                   (car path))                              ; allow re match?
451           (loop (cdr pattern) (cdr path)))
452          (else #f))))
453;; calls rewriter with the current uri; restarts request with the returned uri
454(define (rewrite-uri rewriter)
455  (let* ((r (current-request))
456         (u (request-uri r)))
457    (restart-request
458     (update-request-uri r (rewriter u)))))
459
460(define (link href desc)
461  `(a (@ (href ,href)) ,desc))
462(define (path-link path #!optional desc)
463  (link (path->href path)
464        (or desc (string-intersperse (map ->string path) " "))))
465
466(define ($ var #!optional converter/default)  ; from awful
467    ((http-request-variables) var converter/default))
468(define http-request-variables (make-parameter #f))
469
470;; note: missing full node path should maybe generate 404
471(define (redirect-to path #!key (code 302) (reason "Found") (headers '()))
472  (send-response code: code
473                 reason: reason
474                 headers: `((location ,(uri-relative-to
475                                        (uri-reference path)
476                                        (request-uri (current-request)) ;; spiffy 4.8
477                                        )))))
478
479;; Return 304 Not Modified.  If ACTUAL-MTIME is an integer, it is
480;; returned to the client as the actual modification time of the resource.
481;; You should also resend any associated Cache-control: directive (separately).
482(define (not-modified actual-mtime)
483  (let ((headers (if (integer? actual-mtime)     ; error?
484                     `((last-modified #(,(seconds->utc-time actual-mtime))))
485                     '())))
486    (send-response code: 304 reason: "Not modified" headers: headers)))
487
488;; Compare mtime with If-Modified-Since: header in client request.
489;; If newer, client's copy of resource is outdated and we execute thunk.
490;; Otherwise, return 304 Not Modified.
491(define (last-modified-at mtime thunk)
492  (let ((header-mtime-vec (header-value
493                           'if-modified-since
494                           (request-headers (current-request)))))
495    (if (or (not header-mtime-vec)
496            (> mtime (utc-time->seconds header-mtime-vec)))
497        (with-headers `((last-modified #(,(seconds->utc-time mtime))))
498                      thunk)
499        (not-modified mtime))))
500
501;; SECONDS: number of seconds to cache for; or #t to set a far-future
502;; expiration date (1 year as per RFC); or #f to force no caching.
503(define (cache-for seconds thunk)
504  (if (not seconds)
505      (with-headers `((cache-control (max-age . 0)   ; use "no-cache" ?
506                                     (must-revalidate . #t))) thunk)
507      (let ((seconds (if (integer? seconds)
508                         (min seconds 31536000)
509                         31536000)))
510        (with-headers `((cache-control (max-age . ,seconds))) thunk))))
511(define (cache-privately-for seconds thunk)
512  (if (not seconds)
513      (with-headers `((x-accel-expires 0)  ; nginx hack
514                      (cache-control (max-age . 0)
515                                     (must-revalidate . #t)
516                                     (private . #t))))
517      (let ((seconds (if (integer? seconds)
518                         (min seconds 31536000)
519                         31536000)))
520        (with-headers `((x-accel-expires 0) ; nginx hack
521                        (cache-control (private . #t)
522                                       (max-age . ,seconds)))
523                      thunk))))
524
525;; (define (uri-path->string p)   ; (/ "foo" "bar") -> "/foo/bar"
526;;   (uri->string (update-uri (uri-reference "")
527;;                            path: p)))
528
529(define (proxy-logger)
530  ;; access logger with X-Forwarded-For: header
531  ;; Copied verbatim from spiffy's handle-access-logging
532  (let ((h (request-headers (current-request))))
533    (log-to (access-log)
534            "~A ~A [~A] \"~A ~A HTTP/~A.~A\" ~A \"~A\" \"~A\""
535            (header-value 'x-forwarded-for h "-")
536            (remote-address)
537            (seconds->string (current-seconds))
538            (request-method (current-request))
539            (uri->string (request-uri (current-request)))
540            (request-major (current-request))
541            (request-minor (current-request))
542            (response-code (current-response))
543            (uri->string (header-value 'referer h (uri-reference "-")))
544            (let ((product (header-contents 'user-agent h)))
545              (if product
546                  (product-unparser product)   ; undocumented intarweb proc
547                  "**Unknown product**")))))
548
549;;;
550
551(define (rewrite-chickadee-uri u p)
552  (let ((q (uri-query u)))
553    (update-uri u
554                path: (uri-path (cdoc-uri))
555                query: (if (null? p)
556                           q
557                           (update-param 'path
558                                         (string-intersperse p " ") q)))))
559
560(define (chickadee-handler p)
561  (rewrite-uri (lambda (u) (rewrite-chickadee-uri u p)))) ;?
562
563(define (cdoc-handler p)
564  p ;ignore
565  (with-request-vars*
566   $ (id path q)
567     (cond (path => format-path)
568           (id   => format-id)
569           (q    => (lambda (p)
570                      (with-request-vars*
571                       $ (query-regex query-name)
572                       (if query-regex
573                           (if (string-index p #\space) ; hmm
574                               (format-path-re p)
575                               (format-re p))
576                           (query p)))))
577           (else (format-path "")))))
578
579;;; handlers
580
581;; vhost-map can be used to take control of requests as
582;; they come in, before any handlers are invoked.
583
584(define +vhost-map+
585  `((".*" . ,(lambda (continue)
586               (let ((p (uri-path (request-uri (current-request)))))
587                 (parameterize ((http-request-variables (request-vars))) ; for $
588                   (cond ((equal? (uri-path (cdoc-uri)) p)
589                          => cdoc-handler)
590                         ((match-path (uri-path (chickadee-uri)) p)
591                          => chickadee-handler)
592                         ((and (incremental-search-uri)
593                               (equal? (uri-path (incremental-search-uri)) p))
594                          => incremental-search-handler)
595                         ;; Last resort redirect of root path to main page.
596                         ((equal? p '(/ ""))
597                          (redirect-to (path->href '())))
598                         (else
599                          (continue)))))))))
600
601(define +not-found-handler+
602 (let ((old-handler (handle-not-found)))  ; hmm
603   (lambda (path) ; useless
604     (old-handler path))))
605
606(define +static-file-handler+
607  (let ((old-handler (handle-file)))
608    (lambda (path)
609      (cache-for (cache-static-content-for)
610                 (lambda ()
611                   (old-handler path))))))
612
613;;; start server
614
615(define (chickadee-start-server)
616  (verify-repository)
617  ;; using parameterize, we cannot override in REPL
618  (parameterize ((vhost-map +vhost-map+)
619                 (handle-not-found +not-found-handler+)
620                 (handle-file +static-file-handler+)
621                 (handle-access-logging proxy-logger)
622                 (tcp-buffer-size 1024)
623                 (mime-type-map
624                  `(("js" . application/x-javascript)  ;; spiffy has subpar mime-type
625                    . ,(mime-type-map))))
626    (start-server))))
627
628;; time echo "GET /cdoc?q=p&query-regex=Regex HTTP/1.0" | nc localhost 8080 >/dev/null
629;; (1374 matches) real    0m1.382s (warm cache)
630;;                real    0m1.098s (turn signatures off)
Note: See TracBrowser for help on using the repository browser.