rants

I still haven't been able to find a back up of the rants.ss program.  This is
the latest version I could find, which doesn't use the RSS backend.  I guess
I'll have to reimplement that from my notes.  Shit.  Makes you wish we had
backups on phpwh.  Or maybe I should just post every Scheme program I've ever
written here. ;)

David



;; -*- scheme -*-

;; David Van Horn
;; Sun Sep 15 03:31:58 EDT 2002

;; modified to make latest.html, an HTML fragment for inclusion in BH's
;; index.html
;; Sat Apr  5 18:15:47 EST 2003

;; modified to work as command line program, and cgi program.
;; Sat Oct 26 14:47:59 EDT 2002

#cs
(module rant mzscheme

  (require (lib "date.ss"         "mzlib")
           (lib "cmdline.ss"      "mzlib")
           (lib "match.ss"        "mzlib")
           (lib "cgi.ss"          "net")
           (lib "xml.ss"          "xml")
           (lib "sxml-to-html.ss" "ssax")
           (lib "rfc2822.ss"      "chomsky")
           (lib "1.ss"            "srfi"))

  (provide cgi-add-rant
           cmdline-add-rant
           add-rant
           latest)

  (xexpr-drop-empty-attributes #t)
  (date-display-format 'rfc2822)        ; Should use 'american for HTML,
                                        ; 'rfc2822 for RSS.

  (define base "/home/dvanhorn/public_html/rant/")
  (define url-base "http://ballistichelmet.org/rant/")
  (define (url+ s)
    (format "http://ballistichelmet.org/rant/~a" s))

  ;; this is the CGI interface for adding a rant.
  ;; we extract the rant from the CGI environment variables `rant-subj'
  ;; and `rant-text', add the rant, and then print out an html page to
  ;; report to the user that all is well, and the rant is available for
  ;; viewing.
  (define (cgi-add-rant)
    (output-http-headers)
    (sxml->html

     ;; add the rant and get the filename of the new rant
     (let ((file (add-rant
                  (extract-binding/single 'rant-subj (get-bindings))
                  (extract-binding/single 'rant-text (get-bindings)))))

       ;; let user know where the new rant is placed.
       `(html (head (title "rant submitted")
                    (link (@ (rel "stylesheet")
                             (href ,(url+ "rant.css")))))
              (body (p "your rant has been submitted and is available now at "
                       (a (@ (href ,(url+ file)))
                          ,(url+ file)) ".")
                    (p "thank you")
                    (p (a (@ (href ,url-base))
                          "back to rant index"))
                    (p (a (@ (href "/"))
                          "back to ballistic helmet")))))))

  ;; this is the command line interface for adding a rant.
  ;; the rant subject and body may be given to us on the command line,
  ;; otherwise we prompt the user for them.
  (define (cmdline-add-rant)
    (let ((subj null) (text null))

      (command-line "rant" (current-command-line-arguments)
        (once-each
         [("-s" "--subject") s "the subject of your rant"
          (set! subj s)]
         [("-b" "--body") b "the body of your rant"
          (set! text b)]))

      ;; if the subject and text were not specified on the command line
      ;; then prompt for them from the user.
      (when (null? subj) (set! subj (prompt "subj: "  #\newline)))
      (when (null? text) (set! text (prompt "rant:\n" eof)))

      ;; let the user know where the rant has been placed
      (printf "your rant has been submitted and is available now at ~a~n"
              (url+ (add-rant subj text)))))


  ;; reads characters from the current input port until the character is
  ;; equal to the end object.  returns a string of all characters read.
  ;; the end object is trimmed (ie does not get returned at the end of
  ;; the string)
  (define (prompt p end-obj)
    (printf p)
    (if (eqv? end-obj #\newline)
        (let loop () (let ((x (read-line))) (if (string=? "" x) (loop) x)))
        (apply string-append
               (let loop ((lines null))
                 (let ((line (read-line)))
                   (if (eof-object? line)
                       (reverse! lines)
                       (loop (cons (string-append line "\n")
                                   lines))))))))

  ;; add the rant and return the filename of the new rant
  (define (add-rant subj text) ;; -> string
    (let* ((seconds (current-seconds))
           (date    (date->string (seconds->date seconds) #t))
           (file    (string-append (number->string seconds) ".html"))
           (item    `(item (title ,subj)
                           (link ,(url+ file))
                           (pubDate ,date)
                           (description ,(format "~n<pre>~a</pre>" text)))))

      ;; Insert the new item into the RSS feed file.
      (match (xml->xexpr (with-input-from-file (string-append base "rants.xml")
                           read-xml/element))
        (('rss att ('channel title link desc . items))
         (begin
           (make-index (cons item items))  ;; make index.html
           (with-output-to-file (string-append base "rants.xml")
             (lambda ()
               (write-xml/content
                (xexpr->xml
                 `(rss ,att (channel ,title ,link ,desc ,item ,@items)))))
             'replace))))

      ;; make a file for the rant
      ;; the name of the file is the time (in seconds) plus .html
      (with-output-to-file (string-append base file)
        (lambda ()
          (sxml->html
           `(html (head (title ,(format "rant - ~a" subj))
                        (link (@ (rel "stylesheet")
                                 (href ,(url+ "rant.css")))))
                  (body (h1 ,subj)
                        (h2 "created "
                            ,(parameterize ((date-display-format 'american))
                               (date->string (seconds->date seconds) #t)))
                        (pre (tt ,text))
                        (p (a (@ (href ,url-base))
                              "back to rant index"))
                        (p (a (@ (href "/"))
                              "back to ballistic helmet")))))))

      file)) ;; return the filename of the new rant.

  ; make an index.html page listing all the rants
  (define (make-index rants)  ;; listof item
    (with-output-to-file (string-append base "index.html")
      (lambda ()
        (sxml->html
         `(html (head (title "rant index")
                      (link (@ (rel "stylesheet")
                               (href ,(url+ "rant.css")))))
                (body
                 (table
                  (@ (style "width: 100%;"))
                  (tr
                   (td
                    (img (@ (border "0")
                            (src "http://www.uvm.edu/~dvanhorn/bh.png"))))))
                 (p (@ (style "text-align: right"))
                    (a (@ (href "/")) "back to bh"))
                 (img (@ (src "rant-top.png") (alt "RANTS")))
                 ,(with-input-from-file (string-append base "about.txt") read)
                 (img (@ (src "rant-write.png") (alt "write a new goddamn rant")))
                 (a (@ (href "rants.xml"))
                    (img (@ (src "rss.gif") (alt "rss feed")
                            (align "right") (border "0"))))
                 (p "create a new rant "
                    (a (@ (href ,(url+ "new.html")))
                       "here"))
                 (img (@ (src "rant-read.png") (alt "read a goddamn rant")))
                 (table
                  ,(map
                    (match-lambda
                     (('item ('title t) ('link l) ('pubDate d) . _)
                      `(tr (td ,(parameterize ((date-display-format 'american))
                                  (date->string (rfc2822-date-time->date d) #t)))
                           (td (a (@ (href ,l))
                                  ,t)))))
                    rants))))))
      'replace))

  ;; Requires date.ss to provide all-defined, which is not the default.
  ;; Converts a date into a ballistichelmet "style" string.
  ;; FIX: calculate time zone.
  (define date->bh-date-string
    (let ((add-zero (lambda (n) (if (< n 10)
                                    (string-append "0" (number->string n))
                                    (number->string n)))))
      (lambda (date)
        (format "~a ~a ~a ~a:~a:~a EDT"
                (date-year date)
                (month/number->string (date-month date))
                (add-zero (date-day date))
                (add-zero (date-hour date))
                (add-zero (date-minute date))
                (add-zero (date-second date))
                ;; How do we calculate eg EDT from this?
                ;;(date-time-zone-offset date)
                ))))

  ;; print an HTML report of the latest 4 rants.  For use on BH front page.
  (define (latest)
    (display-xml/content
     (xexpr->xml
      (match (xml->xexpr
              (with-input-from-file (string-append base "rants.xml")
read-xml/element))

             (('rss att ('channel title link desc . items))
              `(div ((id "rants") (class "newsfeed"))
                    ,(make-comment " rant section ")
                    (div ((class "heading"))
                         (h3 "[ rants ]"
                             (a ((href "/rant/rss.xml"))
                                (img ((src "/rant/rss.gif")
                                      (border "0")))
                                ))

                         (p ((class "publish"))
                            (a ((href "/rant/")) "read goddamn rants")
                            " / "
                            (a ((href "/rant/new.html"))
                               "write a goddamn rant")
                            ;;" / "
                            ))
                    ,@(map
                       (match-lambda
                        (('item
                          ('title title) ('link link)
                          ('pubDate date) ('description body . body...))

                         `(div ((class "headline"))
                               (h4 ((class "news"))
                                   (a ((href ,link))
                                      ,title))
                               (p ((class "date"))
                                  ,(parameterize ((date-display-format 'american))
                                      (date->bh-date-string
                                       (rfc2822-date-time->date date))))
                               (p ((class "comment"))
                                  (pre ,(let* ((str (apply string-append (cons
body body...)))
                                               (len (- (string-length str) 6)))
                                          (if (> len 300)
                                              (string-append (substring str 6
300) "...")
                                              (substring str 6 len))))))))
                       (take items 3))))

             (_ (error "malformed channel")))))
    ) ; end of latest

  ) ;; end of rant.ss