")
(define *footer* "")
(define *powered-by* (sprintf "
Powered by
Chicken Scheme ~a.
source /
lib" (chicken-version)))
(define *database-pathname* "/home/ursetto/db/searches.db")
(define (value-of info sym)
(let ((vals (info sym)))
(if (null? vals) #f
(stream->string (car vals)))))
(define (main info)
(stream-append
(string->stream "Content-type: text/html\n\n")
(string->stream *header*)
(string->stream (create-table info))
(string->stream (creation-time *start-time*))
(string->stream *powered-by*)
(string->stream *footer*)))
;; We could obtain a crappy "upper bound" on table rows by checking the
;; length of list returned by generate-results; if less than LIMIT,
;; there are no more records.
(define (create-table info)
(let* ((offset (or (numeric>= (value-of info 'start) 0) 0))
(limit (or (numeric-within (value-of info 'num) 0 101) 25))
(sort-by (verified-sort info)) ; can be #f, default (date) assumed in generate-results
(dir (verified-dir info))) ; can be #f, default assumed of in generate-results
(string-append "
Group by "
(date-url) " | "
(hits-url) " | "
(term-url)
"
"
(prev-url offset limit sort-by dir)
" | "
(next-url offset limit sort-by dir)
"
"
"
"
(apply string-append
(generate-results offset limit sort-by dir))
"
")))
;; Generate strings representing Previous and Next URLs
(define (prev-url offset limit sort-by dir)
(string-append
"
string limit)
"&start=" (number->string (max 0 (- offset limit)))
(if sort-by (string-append "&sort=" sort-by) "") ; can be #f; don't include if so
(if dir (string-append "&dir=" dir) "")
"\">« Prev"))
;; Offset is unbounded, as don't know how to get maximum
;; number of records yet.
(define (next-url offset limit sort-by dir)
(string-append
"
string limit)
"&start=" (number->string (+ offset limit))
(if sort-by (string-append "&sort=" sort-by) "") ; can be #f; don't include if so
(if dir (string-append "&dir=" dir) "")
"\">Next »"))
(define (hits-url)
(string-append
"
Hits"))
(define (date-url)
(string-append
"
Date"))
(define (term-url)
(string-append
"
Term"))
;; These expect a string and a low (or low/high) value
;; and return a number or #f.
(define (numeric-within str low high)
(and-let* ((num (numeric>= str low)))
(and (< num high) num)))
(define (numeric>= str low)
(cond ((not (string? str)) #f)
((string->number str)
=> (lambda (n) (and (>= n low) n)))
(else #f)))
(define (verified-sort info)
(let ((sort-by (value-of info 'sort)))
(and sort-by
(member sort-by '("alpha" "hits" "date"))
sort-by)))
(define (verified-dir info)
(let ((dir (value-of info 'dir)))
(and dir
(member dir '("desc" "asc"))
dir)))
;; direction and sort-by, if not #f, are already valid values. If #f, pick a default.
(define (generate-results offset limit sort-by direction)
(define date-header (string-append
"
| Date | From | Search term |
|---|
"))
(define hits-header (string-append
"
| Hits | From | "
"Search term |
|---|
"))
(define term-header (string-append
"
| "
"Hits | From | "
"Search term |
|---|
"))
(define (lookup-and-render-rows stmt render table-header)
(cons table-header ;; Add table header.
(call-with-db (lambda (db)
(sqlite3:call-with-temporary-statements
(lambda (s)
(sqlite3:map-row render s))
db
stmt)))))
(cond ((equal? sort-by "hits")
(lookup-and-render-rows
(sprintf "select count(*) as number, pretty_name, term from searches WHERE term NOTNULL group by term order by number ~a limit ~a offset ~a;" (or direction "desc") limit offset)
render-hit-row
hits-header))
((equal? sort-by "alpha")
(lookup-and-render-rows
;; Note that GROUP orders by ASC; to order by DESC we must add an
;; ORDER clause, which slows things down considerably. For now, we do not
;; report hits (eliminating the GROUP clause) when direction is DESC.
;; Strangely, ASC is somewhat slower, but incurs no penalty for hit counting.
(if (equal? direction "desc")
(sprintf "select distinct \"-\", pretty_name, term from searches WHERE term NOTNULL ORDER BY term desc limit ~a offset ~a;" limit offset)
(sprintf "select count(*), pretty_name, term from searches WHERE term NOTNULL GROUP BY term limit ~a offset ~a;" limit offset))
render-hit-row
term-header))
(else ; (equal? sort-by "date")
(lookup-and-render-rows
(sprintf "SELECT time, pretty_name, term from searches WHERE term NOTNULL order by time ~a limit ~a offset ~a;" (or direction "desc") limit offset)
render-date-row
date-header))))
(define (call-with-db proc) ; use dynamic-wind or handle exception
(let* ((db (open-db))
(result (proc db)))
(sqlite3:finalize! db)
result))
;; Render a row of a hits table. Suitable for passing to sqlite3:map-row.
(define (render-hit-row hits pretty-name term)
(string-append "
"
"| " (->string hits) " | "
"" pretty-name " | "
"" term " | "
"
"))
;; Render a row of a date table. Suitable for passing to sqlite3:map-row.
(define (render-date-row time pretty-name term)
(string-append "
"
"| " (seconds->date-row-string time) " | "
"" pretty-name " | "
"" term " | "
"
"))
;; '#(seconds minutes hours mday month year wday yday dstflag timezone)
(define (seconds->date-row-string time)
;; Probably strftime would be easiest.
(let* ((u (seconds->utc-time time))
(v (lambda (i) (vector-ref u i)))
(s (lambda (n) (if (and (>= n 0) (< n 10))
(conc "0" n) n)))) ; poor man's %02d
(sprintf "~a-~a-~a ~a:~a"
(+ 1900 (v 5))
(s (+ (v 4) 1))
(s (v 3)) (s (v 2)) (s (v 1)))))
(define (open-db)
(sqlite3:open *database-pathname*))
(define (creation-time start)
(string-append
"
Page generated in "
(number->string
(/ (- (current-milliseconds) start) 1000))
" seconds."))
;;; Main CGI execution.
(cgi-main main)
;;; Testing
#|
;; Return an "info" procedure suitable for passing to main.
;; Each argument is a '(key-symbol string-value) pair which will
;; be used as dummy CGI data.
(define (inf . pairs)
(define (pair key val)
(list key (string->stream val)))
(let ((alist (map (lambda (x)
(pair (car x) (cadr x)))
pairs)))
(lambda (sym)
(or (alist-ref sym alist)
'() ))))
;; e.g.
(print (stream->string
(main
(inf '(sort "date")) )))
|#