rants

#|                                                              -*- Scheme -*-
   Copyright (c) 2003 David Van Horn
   Licensed under the Academic Free License version 2.0

   [email protected]

   removed dependency on SSAX, minor bug fixes, released under AFL 2.0.
   Sun Mar  7 01:31:25 EST 2004

   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

   original version
   Sun Sep 15 03:31:58 EDT 2002
|#

#cs
(module rant mzscheme
  (require (lib "cgi.ss"          "net")
           (lib "date.ss"         "mzlib")
           (lib "cmdline.ss"      "mzlib")
           (lib "xml.ss" "xml")
           (lib "match.ss"))

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

  (define base "/home/bh/www/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)
    (write-xml/content
     (xexpr->xml
      ;; 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 () ,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 ()
          (write-xml/content
           (xexpr->xml
            `(html (head (title ,(format "rant - ~a" subj))
                         (link ((rel "stylesheet")
                                (href ,(url+ "rant.css")))))
                  (body (h1 ,subj)
                        (h2 "created " ,date)
                        (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 ()
        (display-xml/content
         (xexpr->xml
          `(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")))
             (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 ,d)
                        (td (a ((href ,l))
                               ,t)))))
                 rants)))))))
      'replace))

  ) ;; end of rant.ss