/sighting-server.rkt

  1#! /bin/sh
  2#| Hey Emacs, this is -*-scheme-*- code!
  3|#
  4
  5;; This is a "servlet"
  6;; (http://pre.plt-scheme.org/docs/html/web-server/servlet.html) that
  7;; displays the sightings database in a simple web page.
  8
  9;; for i in sighting-server.ss sighting.ss sightings.db; do ln -s $i
 10;; /usr/local/src/plt/collects/web-server/default-web-root/servlets/; done
 11;;
 12;; http://server:8080/servlets/sighting-server.ss
 13#lang racket
 14
 15(require (planet offby1/offby1/zdate)
 16         mzlib/etc
 17         web-server/servlet
 18         net/url)
 19
 20(provide interface-version timeout start)
 21
 22(define interface-version 'v1)
 23(define timeout +inf.0)
 24
 25;; a module for the PLT web server.  It reads "sightings.db", and
 26;; nicely formats the data for display, as a table -- one entry per
 27;; row.  The table has buttons on top of the "who" and "when" columns;
 28;; if you click one of those buttons, it sorts the table by that
 29;; column.
 30
 31(define *sightings-file-path*
 32  (build-path
 33   (this-expression-source-directory)
 34   "sightings.db"))
 35
 36;; this might break, if it gets called at the same time as some other
 37;; process (namely, the IRC bot) is writing the file.
 38(define (*sightings*)
 39  (hash-map (with-input-from-file *sightings-file-path* read)
 40            cons))
 41
 42(define (make-button column-name)
 43  `(th (input ([name "column"]
 44               [value ,(symbol->string column-name)]
 45               [type "submit"])
 46               )))
 47
 48(define (start initial-request)
 49
 50  (fprintf
 51   (current-error-port)
 52   "~a ~a ~s~%"
 53   (zdate)
 54   (request-client-ip initial-request)
 55   (url->string (request-uri initial-request)))
 56
 57  (let ([requested-sort-column
 58         (let ([datum (cond
 59                       [(assq 'column (request-bindings initial-request)) => cdr]
 60                       [else 'who])])
 61           (cond
 62            [(string? datum) (string->symbol datum)]
 63            [else datum]))])
 64
 65    (define generate-response
 66      (lambda ()
 67        (let ([s (*sightings*)])
 68        `(html
 69          (body
 70           (h3
 71            ,(format
 72              "~a sightings as of ~a, sorted by ~s"
 73              (length s)
 74              (zdate (file-or-directory-modify-seconds *sightings-file-path*))
 75              requested-sort-column))
 76
 77           (table ([rules "all"])
 78
 79                  (tr
 80                   (form ([method "get"]
 81                          [action ,(url->string (request-uri initial-request))])
 82                         ,@(map make-button (list 'who 'where 'when 'what))))
 83
 84                  ,@(map
 85                     (lambda (p)
 86                       `(tr
 87                         (td (small (tt ,(format "~a" (car p)))))
 88                         (td (small (tt ,(format "~a" (sighting-where (cdr p))))))
 89                         (td (small (tt ,(format "~a" (zdate  (sighting-when (cdr p)))))))
 90                         (td (small (tt ,(format "~a" (string-join
 91                                                       (sighting-words (cdr p)) " ")))))))
 92                     (sort
 93                      s
 94                      (lambda (p1 p2)
 95                        (case requested-sort-column
 96                          [(who)
 97                           (string-ci<? (car p1)
 98                                        (car p2))]
 99                          [(where)
100                           (string-ci<? (sighting-where (cdr p1))
101                                        (sighting-where (cdr p2)))]
102
103                          ;; newest first
104                          [(when)
105                           (> (sighting-when (cdr p1))
106                              (sighting-when (cdr p2)))]
107
108                          [else
109                           (string-ci<? (string-join
110                                         (sighting-words (cdr p1)) " ")
111                                        (string-join
112                                         (sighting-words (cdr p2)) " "))]))))))))))
113
114    (with-errors-to-browser send/finish generate-response))
115  )