reddit.ss

   1 ":";exec /home/private/plt/bin/mzscheme -r $0 "$@"
   2 ; -*- mode: scheme -*-
   3 ;; (this is deprecated code; see the .py files)
   4 ;; tagcloud-like for reddit
   5
   6 (require (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
   7          (planet "htmlprag.ss" ("neil" "htmlprag.plt" 1 3))
   8          (planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
   9          (planet "html.ss" ("jim" "webit.plt" 1 1)) ; for HTML generation
  10          (lib "string.ss")
  11          (lib "13.ss" "srfi")
  12          (lib "19.ss" "srfi"))
  13
  14 ; TODO: `id' is the http URL. I should use a better name
  15 (define-struct reddit-link
  16   (id href title comments score))
  17
  18 (define (all-reddit-links reddit-url)
  19   ;; we are scrapping reddit HTML (thanks to htmlprag, ssax)
  20   (let* ((doc    (html->sxml (open-input-resource reddit-url)))
  21          (tr-lst ((sxpath "//tr[contains(@class, 'Row')]") doc)))
  22
  23     ;; tr-lst -- the ugly reddit HTML
  24     ;; what follows is, thus, an ugly hack
  25     (define (generate-reddit-links tr-lst)
  26       (if (null? tr-lst) '()
  27           (begin
  28             (let* ((row1 (car  tr-lst))
  29                    (row2 (cadr tr-lst))
  30                    (link-ele     ((sxpath "/td[@colspan = 3]/a/@href/text()") row1))
  31                    (title-ele    ((sxpath "/td[@colspan = 3]/a/text()") row1))
  32                    (id-ele       ((sxpath "/td[@colspan = 3]/a[@class='bylink']/@href/text()") row2))
  33                    (score-ele    ((sxpath "/td[@colspan = 3]/span[contains(@id, 'score')]/text()") row2))
  34                    (comments-ele ((sxpath "/td[@colspan = 3]/a[@class='bylink']/text()") row2)))
  35
  36               ;; extract values from sxml nodes
  37               (let ((href     (car link-ele))
  38                     (id       (if (string-contains (car id-ele) "http://") ; normalize url
  39                                   (car id-ele)
  40                                   (format "~a~a" reddit-url (car id-ele))))
  41                     (title    (car title-ele))
  42                     (comments (string->number
  43                                (car (or
  44                                      (regexp-match "[0-9]+" (car comments-ele))
  45                                      '("0")))))
  46                     (score    (if (null? score-ele) 0 ; XXX: link submitted < 1 hr ?
  47                                   (string->number (car (regexp-match "[0-9]+" (car score-ele)))))))
  48                 (cons (make-reddit-link id href title comments score)
  49                       (generate-reddit-links (cddr tr-lst))))))))
  50
  51     (generate-reddit-links tr-lst)))
  52
  53
  54 (define (render-reddit url)
  55
  56   (let* ((links     (all-reddit-links url))
  57          (max-score (apply max (map reddit-link-score links))))
  58
  59     ;; we assign a suitable font-size based on the relative scores
  60     ;; just like tagclouds <http://flickr.com/photos/tags/>
  61     (define (find-font-size score)
  62       (let* ((size-min   12) ; minimum css font-size
  63              (size-max   36)
  64              (size-inc   2)
  65              (size-total (/ (- size-max size-min)
  66                             size-inc)))
  67         (+ size-min
  68            (* size-inc
  69               (quotient (* score size-total)
  70                         max-score)))))
  71
  72
  73     (define (render-reddit-link link)
  74       (h4:span h4:style: "margin-right: 10px;"
  75                (h4:sup
  76                 (h4:a h4:style: "color: gray;"
  77                       h4:href:  (reddit-link-id link)
  78                       h4:title: (format "Click to see ~a comments in reddit"
  79                                         (reddit-link-comments link))
  80                       (reddit-link-comments link)))
  81                (h4:a h4:href:  (reddit-link-href link)
  82                      h4:title: (format "~a points"
  83                                        (if (= 0 (reddit-link-score link))
  84                                            "-"
  85                                            (reddit-link-score link)))
  86                      h4:style: (format "font-size: ~apx;"
  87                                        (find-font-size (reddit-link-score link)))
  88                      (reddit-link-title link))))
  89
  90     (h4:div (map render-reddit-link links))))
  91
  92 (define (generate-html)
  93
  94   (define css-style
  95     "body {
  96   font-family: verdana;
  97   background-color: white;
  98   margin-left: 3%;
  99 }
 100
 101 a:link    { text-decoration: none;  }
 102 a:visited { text-decoration: none;  }
 103 a:hover   { text-decoration: none; background-color: #b9badb; }
 104 a:active  { text-decoration: none; background-color: #b9badb; }
 105
 106 img { border: none; }
 107 ")
 108
 109   (srl:sxml->xml
 110    (h4:html
 111     (h4:p "This is the " (h4:b "reddit cloud") ", written in "
 112           (h4:a h4:href: "http://nearfar.org/code/reddit/"
 113                 "lisp") ".")
 114     (h4:head (h4:title "reddit cloud")
 115              (h4:style h4:type: "text/css"
 116                        css-style))
 117     (h4:body (h4:h2 (h4:a h4:href: "http://reddit.com/"
 118                           "reddit.com"))
 119              (render-reddit "http://reddit.com")
 120              (h4:br)
 121              (h4:h2 (h4:a h4:id: "programming"
 122                           h4:href: "http://programming.reddit.com/"
 123                           "programming.reddit.com"))
 124              (render-reddit "http://programming.reddit.com")
 125              (h4:br)
 126              (h4:h2 (h4:a h4:id: "science"
 127                           h4:href: "http://science.reddit.com/"
 128                           "science.reddit.com"))
 129              (render-reddit "http://science.reddit.com")
 130              (h4:br)
 131              (h4:div h4:style: "display: none;"
 132                      (date->string (current-date)))))))
 133
 134 ; http://schemecookbook.org/Cookbook/FileRead
 135 (define (read-all path)
 136   (let ((size (file-size path)))
 137     (call-with-input-file path
 138       (lambda (p)
 139         (read-string size p)))))
 140
 141 (define (cached-html html-generator timeout)
 142   "cache the html returned by `html-genenerator' for `timeout' seconds"
 143   (let ((cache-life     (lambda ()
 144                           (- (time-second (current-time))
 145                              (if (file-exists? "cache")
 146                                  (file-or-directory-modify-seconds "cache")
 147                                  -1))))
 148         (update-cache   (lambda (content)
 149                           (if (file-exists? "cache") (delete-file "cache"))
 150                           (with-output-to-file "cache"
 151                             (lambda () (display content) content))))
 152         (retrieve-cache (lambda ()
 153                           (read-all "cache"))))
 154     (if (> (cache-life) timeout)
 155         (update-cache (html-generator))
 156         (retrieve-cache))))
 157
 158 (define (timed code)
 159   "time the `code' form"
 160   (let ((time-before (time-second (current-time))))
 161     (eval code)
 162     (-  (time-second (current-time)) time-before)))
 163
 164 (define (main)
 165   (display "content-type: text/html; charset=utf-8") (newline)
 166   (newline)
 167   (display (format "<!-- ~a secs at ~a -->"
 168                    (timed
 169                     '(display (cached-html generate-html 300)))
 170                    (date->string (current-date)))))
 171
 172 (main)