Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: master
Fetching contributors…

Cannot retrieve contributors at this time

executable file 258 lines (224 sloc) 7.142 kB
#!/bin/sh
#-*- scheme -*-
#
# Copyright (C) 2012 Greg Benison
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
export GUILE_LOAD_PATH=$GUILE_LOAD_PATH:`pwd`;
export LTDL_LIBRARY_PATH=$LTDL_LIBRARY_PATH:`pwd`;
export GUILE_WARN_DEPRECATED=no;
# exec guile -s $0 2>/dev/null
exec guile --listen -s $0 $@ 2>>guile-error.log
# exec guile -s $0 $@ 2>>guile-error.log
!#
(use-modules (taubatron)
(sxml simple)
(rnrs bytevectors)
(srfi srfi-1)
(web request)
(web server))
(define socket-file-name
(or (false-if-exception (cadr (command-line)))
"/tmp/test.sock"))
(define (sxml->text sxml)
(with-output-to-string
(lambda () (sxml->xml sxml))))
(define (as-li x)`(li ,x))
(define (->string x)
(format #f "~a" x))
(define (scanl op init xs)
(if (null? xs)
(list init)
(cons init
(scanl op (op init (car xs)) (cdr xs)))))
;; Convert a list of words into a list of alists
; ((c1a . n1b ...)(c1b . n1b))
; such that if c1a /= c1b, then n1a /= n1b.
;
; Useful for coloring the letters in "Tauba style"
(define (annotate-word-sequence words)
(let loop ((init (word->init (car words)))
(rest (cdr words)))
(if (null? rest)
(list init)
(cons init
(loop (ensure-tags
(match-attributes (car rest) init))
(cdr rest))))))
(define (word->init word)
(map (lambda (c) (cons c 1)) (string->list word)))
(define (match-attribute char template)
(cond ((null? template) (cons (cons char #f) template))
((equal? char (caar template))
template)
(else
(let ((next (match-attribute char (cdr template))))
(cons (car next)
(cons (car template) (cdr next)))))))
(define (match-attribute-cdr template char)
(match-attribute char (cdr template)))
(define (match-attributes word template)
(map car (cdr (scanl match-attribute-cdr (cons #f template) (string->list word)))))
(define (highest-tag template)
(apply max (filter number? (map cdr template))))
(define (ensure-tags template)
(let loop ((highest (highest-tag template))
(template template))
(cond ((null? template) '())
((number? (cdar template))
(cons (car template)
(loop highest (cdr template))))
(else (cons (cons (caar template)
(+ 1 highest))
(loop (+ 1 highest) (cdr template)))))))
;; Render subsets of 'path' of the form (p1,p2,p3,...p_n) such that
;; the length of the rendered string is <= max-length.
(define (abbreviate-path path max-length)
(let ((full-string (string-join path " - ")))
(if (< (string-length full-string) max-length)
full-string
(let loop ((prev "")
(n 1))
(let ((candidate (string-append
(string-join (take path n) " - ")
"..."
(last path))))
(if (> (string-length candidate) max-length)
prev
(loop candidate (+ n 1))))))))
(define (make-tweet-button path)
`(div
(a (@ (href "https://twitter.com/share")
(data-text ,(abbreviate-path path 90))
(data-related "gcbenison")
(data-hashtags "taubatron")
(data-count "none")
(class "twitter-share-button"))
"Tweet this result")))
;;
;; Create a procedure that transforms a string
;; into a list of either:
;; one-character strings, or spans containing
;; one character with a class supplied by
;; 'classes', a mapping from characters to class
;; names.
;;
(define (word-apply-classes classes)
(lambda (word)
(map
(lambda (c)
(let ((class (assoc-ref classes (char-downcase c)))
(str (list->string (list c))))
(if class
`(span (@ (class ,class)) ,str)
str)))
(string->list word))))
(define taubatron-classes
(word-apply-classes '((#\t . "t_color")
(#\o . "o_color")
(#\n . "n_color"))))
(define (make-taubatron-reply start end)
`(html
(head
(title "The Taubatron")
(link (@ (rel "canonical") (href "http://gcbenison.wordpress.com")))
(link (@ (rel "stylesheet") (type "text/css") (href "taubatron.css")))
(script (@ (language "javascript")
(src "http://localhost:8081/tweet.js"))
" "))
(body
(@ (onload "tweetinit()"))
(div (@ (id "header"))
(h1 "The "
(a (@ (href "taubatron"))
,(taubatron-classes "taubatron"))))
(div (@ (id "content"))
(div (@ (id "left-column"))
,(taubatron-meta-column))
(div (@ (id "right-column"))
(div
(@ (class "centering"))
,(make-taubatron-form start end)))))))
(define taubatron-meta-column
(let* ((handle (open-input-file "about.html"))
(contents (xml->sxml handle)))
(close handle)
(lambda ()
contents)))
;; Render a path of words [String] into SXML
(define (path->sxml path)
`(div (@ (id "result"))
(ul
,(map
(lambda (word)
`(li ,(map
(lambda (char)
`(span (@ (class ,(format #f "_~a" (cdr char))))
,(->string (car char))))
word)))
(annotate-word-sequence path)))
(div (@ (class "centering"))
(div
,(make-tweet-button path)))))
(define (make-taubatron-form start end)
(let ((input? (and (string? start) (string? end))))
`(,(if input?
(catch
'taubatron-error
(lambda ()
(path->sxml (find-path start end)))
(lambda (key proc msg . args)
`(div (div (@ (class "error"))
"Error:"
(p ,msg)))))
"")
(div (form (@ (method "post")
(action "taubatron"))
"Transform"
(input (@ (type "text")
(name "start")))
"into"
(input (@ (type "text")
(name "end")))
(input (@ (type "submit")
(value "Go"))))))))
(define (list->assoc-pair lst)
(if (null? (cdr lst))
(cons (car lst) #f)
(cons (car lst)
(cadr lst))))
(define (parse-post-data data)
(map list->assoc-pair
(map
(lambda (str)
(string-split str #\=))
(string-split (utf8->string data) #\&))))
(define (as-html-reply sxml)
(values '((content-type . (text/html)))
(sxml->text sxml)))
(define (tt-handler request request-body)
(cond ((eq? (request-method request) 'GET)
(as-html-reply (make-taubatron-reply #f #f)))
((eq? (request-method request) 'POST)
(let ((post-data (parse-post-data request-body)))
(as-html-reply (make-taubatron-reply
(assoc-ref post-data "start")
(assoc-ref post-data "end")))))))
(define (make-unix-socket fname)
(let ((server-socket (socket PF_UNIX SOCK_STREAM 0)))
(bind server-socket AF_UNIX fname)
server-socket))
(run-server tt-handler 'http `(#:socket ,(make-unix-socket socket-file-name)))
Jump to Line
Something went wrong with that request. Please try again.