| 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 " » " 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 " » ") ,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) |
|---|
