Re: rants

You love scheme!

On Mar 7, 2004, at 2:17 AM, dvanhorn wrote:

> #|                                                              -*- 
> 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
>
> _______________________________________________
> devel mailing list
> [email protected]
> http://ballistichelmet.org/mailman/listinfo/devel
>