Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…
Cannot retrieve contributors at this time
572 lines (518 sloc) 25.2 KB
(module pastiche (pastiche)
(import chicken scheme)
(use awful
(srfi 1 13)
;;; Utils
(define (tabularize data #!key header)
(append '(table)
(if header
`((tr ,@(map (lambda (item) `(th ,item)) header)))
(let ((body
(map (lambda (line)
(append '(tr)
(map (lambda (cell) `(td ,cell)) line)))
(define (text-input id)
`(input (@ (type "text")
(name ,id)
(maxlength 78)
(id ,id))))
(define (hidden-input id value)
`(input (@ (type "hidden")
(id ,id)
(name ,id)
(value ,value))))
(define (preferred-languages accept-language-contents)
(let ((qualities (fold (lambda (x s)
(cons (get-value x)
(get-param 'q x)
(sort qualities (lambda (a b)
(> (cdr a) (cdr b))))))
(define (find-espeak-languages executable data-dir)
(let* ((raw-input (with-input-from-pipe (string-append executable
" --version")
(derived-data-dir (and (not (eof-object? raw-input))
(last (string-split raw-input " ")))))
(cond ((or (and data-dir (directory-exists? data-dir))
(and derived-data-dir (directory-exists? derived-data-dir))) =>
(lambda (dir)
(find-files (make-pathname dir "voices") action: (lambda (f s) (cons (pathname-strip-directory f) s)) test: file-exists?)))
(derived-data-dir ;; executable has been found, but directory does not exist
(error "audible captchas have been configured but the call to espeak did not work.")))))
(define (select-preferred-language available preferences)
(or (find (cut member <> available) (map (lambda (p) (symbol->string (car p))) preferences)) "en"))
(define espeak-available-languages '())
;;; Captchas
(define-record captcha string figlet)
(define (tool-exists? tool)
(let ((paths (string-split (get-environment-variable "PATH")
(if (eq? (software-type) 'windows)
(let loop ((paths paths))
(if (null? paths)
(let ((path (car paths)))
(or (file-exists? (make-pathname path tool))
(loop (cdr paths))))))))
(define (create-captchas num #!key (min-captcha-len 4) (max-captcha-len 8))
;; returns an alist mapping captcha hashes to captcha records
(define chars '#(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
#\n #\o #\p #\q #\r #\s #\t #\u #\v #\x #\y #\z))
(define random-captcha
(let ((chars-len (vector-length chars)))
(lambda ()
(let loop ((n (+ min-captcha-len
(random (- max-captcha-len
(if (zero? n)
(cons (vector-ref chars (random chars-len))
(loop (- n 1)))))))))
(define (figlet str)
(call-with-input-pipe (string-append "figlet " str) read-all))
(let loop ((n (sub1 num)))
(if (zero? n)
(let ((captcha-string (random-captcha)))
(cons (string->sha1sum captcha-string)
(make-captcha captcha-string
(figlet captcha-string)))
(loop (- n 1)))))))
(define (get-captcha captchas)
(list-ref captchas (random (length captchas))))
(define (string-as-wav espeak-binary s preferred-languages)
(let-values (((in out pid) (process espeak-binary `("-s 10" "--stdout" "-v"
,(select-preferred-language espeak-available-languages preferred-languages)))))
(fprintf out "~s" (list->string (intersperse (string->list s) #\space)))
(close-output-port out)
(let ((r (read-all in)))
(close-input-port in)
;;; Pastiche
(define (pastiche base-path db-file
#!key (vandusen-port 22722)
(vandusen-host "localhost")
(base-url "")
(use-captcha? #t)
(audible-captcha? #t)
(espeak-binary "espeak")
(espeak-data-dir #f)
(num-captchas 500)
(browsing-steps 15)
(awful-settings (lambda (_) (_))))
(define (delete-and-refill-captchas clist captcha)
(if (= 1 (length clist))
(create-captchas num-captchas)
(alist-delete captcha clist)))
(define base-path-pattern
(irregex (string-append (string-chomp base-path "/") "(/.*)*")))
(define-app pastiche
matcher: (lambda (path)
(irregex-match base-path-pattern path))
handler-hook: (lambda (handler)
(parameterize ((app-root-path base-path)
(enable-sxml #t)
(db-credentials db-file)
(page-css "//"))
(awful-settings handler)))
(when (and use-captcha? (not (tool-exists? "figlet")))
(print "WARNING: `use-captcha?' indicates that captchas are enabled but figlet "
"doesn't seem to be installed. Disabling captchas.")
(set! use-captcha? #f))
(when (and use-captcha? audible-captcha? (not (tool-exists? "espeak")))
(print "WARNING: `use-captcha?' indicates that audible captchas are enabled but espeak "
"doesn't seem to be installed. Disabling captchas.")
(set! audible-captcha? #f))
(set! espeak-available-languages (find-espeak-languages espeak-binary espeak-data-dir))
(when (and force-vandusen-notification?
(or (not vandusen-host)
(not vandusen-port)))
(error 'pastiche
"`force-vandusen-notification?' requires both `vandusen-host' and `vandusen-port' to be set."))
(define captchas (and use-captcha? (create-captchas num-captchas)))
;; The database needs to be initialised once
(unless (file-exists? db-file)
(let ((db (open-database db-file)))
(exec (sql db "create table pastes(hash text, author text, title text, time float, paste text)"))
(close-database db)))
(define (notify nick title url)
(when vandusen-host
(let ((cleaned-nick (with-input-from-string nick html-strip))
(cleaned-title (with-input-from-string title html-strip)))
(let ((stuff (sprintf "#chicken ~s pasted ~s ~a"
cleaned-nick cleaned-title (make-pathname base-url url))))
(let-values (((i o) (tcp-connect vandusen-host vandusen-port)))
(display stuff o)
(newline o)
(close-input-port i)
(close-output-port o)))))))
; old "select * from pastes order by time desc limit ?,?"
(define (fetch-last-pastes count #!key (offset 0))
(let ((r ($db "select * from pastes p where time = (select min(time) from pastes p2 where p2.hash=p.hash) order by time desc limit ?,?" values: (list offset count))))
(define (make-post-table n #!key (offset 0))
(define (format-row r)
(list (second r) ; Nickname
`(a (@ (href ,(make-pathname base-path (string-append "/paste?id=" (first r))))
(id "paste-url"))
,(third r)) ; title
(prettify-time (fourth r)))) ; date
`(div (@ (class "paste-table"))
(tabularize (map format-row (fetch-last-pastes n offset: offset))
header: '("Nickname" "Title" "Date"))
'(p "No pastes so far."))))
(define (navigation-links)
`(div (@ (id "menu"))
(ul ,@(map (lambda (m)
`(li (a (@ (href ,(make-pathname base-path (car m))))
,(cdr m))))
'(("" . "New Paste")
("browse" . "Browse pastes")
("about" . "What is this?"))))))
(define (recent-pastes n)
`(div (@ (class "paste-list"))
(h2 "The last " ,n " pastes so far: ")
,(make-post-table n)))
(define (paste-form #!key annotate-id)
(let* ((hash/captcha (and use-captcha? (get-captcha captchas)))
(captcha-hash (and use-captcha? (car hash/captcha)))
(captcha (and use-captcha? (cdr hash/captcha))))
`(div (@ (class "paste-form"))
(h2 "Enter a new " ,(if annotate-id " annotation:" " paste:"))
(form (@ (method "post")
(action ,(make-pathname base-path "paste")))
,(if use-captcha?
(hidden-input 'captcha-hash captcha-hash)
`(("Your nick: " ,(text-input 'nick))
("The title of your paste:" ,(text-input 'title) )
(("Your paste " (i "(mandatory)" " :"))
(textarea (@ (id "paste")
(name "paste")
(cols 60)
(rows 24)))))
(if use-captcha?
`(("Type in the text below:" ,(text-input 'captcha-user-answer))
("" (pre (@ (id "captcha"))
,(captcha-figlet captcha)))
,(if audible-captcha?
`("Visually impaired? Let me spell it for you (wav file)"
(audio (@ (src ,(make-pathname base-path
(sprintf "captcha?hash=~a.wav" captcha-hash)))
(preload "metadata")
(controls "controls")))
(a (@ (href ,(make-pathname base-path
(sprintf "captcha?hash=~a.wav" captcha-hash))))
"download WAV"))
`(("" ,(if force-vandusen-notification?
(hidden-input 'notify-irc "yes")
(if vandusen-host
`(input (@ (name "notify-irc")
(type "checkbox")
(checked "checked"))
"Please notify the #chicken channel on freenode.")
(,(if annotate-id
(hidden-input 'id annotate-id)
((input (@ (type "submit")
(value "Submit paste!"))))))))))))
(define (fetch-paste id)
(and id
(let ((r ($db "select * from pastes where hash=? order by time desc" values: (list id))))
(and (not (null? r)) r))))
(define (update-paste id snippet)
(insert-paste id snippet))
(define (insert-paste id paste)
(let ((author (first paste))
(title (second paste))
(time (third paste))
(paste (fourth paste)))
($db "insert into pastes (hash, author, title, time, paste) values (?,?,?,?,?)"
values: (list id author title time paste))))
(define (bail-out . reasons)
`((h1 "Ooops, something went wrong")
(div (@ (id "failure-reason"))
,(fold (lambda (i r)
(sprintf "~a~a" r i))
"" reasons))
"I am sorry for this, you better go back."))
(define (prettify-time t)
(let* ((delta (- (current-seconds) t))
(lambda (d l)
(let ((r (inexact->exact (floor (/ delta d)))))
(if (and (< 0 r) (>= l r)) r #f)))))
(cond ((fits (* 60 60 24) 3) =>
(lambda (d) (sprintf "~a days ago" d)))
((fits (* 60 60) 24) =>
(lambda (hrs)
(sprintf "~a hours ago" hrs)))
((fits 60 (* 60 5)) => (lambda (m) (sprintf "~a minutes ago" m)))
((fits 1 120) => (lambda (_) (sprintf "just now!")))
(else (sprintf "on ~a" (seconds->string t))))))
(define (print-snippet s #!key annotation? (count 0))
`((div (@ (class "paste-header"))
(h3 (a (@ (name ,(sprintf "a~A" count)))
,(third s))
,(if annotation? " added " " pasted ") " by " ,(second s) " "
,(prettify-time (fourth s)))
(div (@ (class "paste"))
(pre (tt (@ (class "highlight scheme-language"))
(literal ,(if (< (string-length (fifth s)) 5000) ;; only colorize if the paste isn't too long
(html-colorize 'scheme (fifth s))
(fifth s))))))
(div (@ (class "paste-footer"))
" [ "
(a (@ (href ,(make-pathname base-path
(sprintf "paste?id=~a#a~a" (first s) count))))
" | "
(a (@ (href ,(make-pathname base-path
(sprintf "raw?id=~a&annotation=~a" (first s) count))))
" ] "))))
(define (format-all-snippets snippets)
(fold (let ((c (length snippets)))
(lambda (p s)
(set! c (sub1 c))
`(,(print-snippet p annotation?: (= c (- (length snippets) 1)) count: c)
(define-page "/" ;; the main page, prefixed by base-path
(lambda ()
(div (@ (id "content"))
(h1 (@ (id "heading")
(align "center"))
"Welcome to the chicken scheme pasting service")
(,(or (and-let* ((id ($ 'id))
(annotate ($ 'annotate)))
(cond ((fetch-paste id)
=> (lambda (p)
`(,(format-all-snippets p)
(h2 "Your annotation:")
,(paste-form annotate-id: id))))
(else (bail-out "Found no paste to annotate with this id."))))
title: "Pastiche: the CHICKEN Scheme pasting service")
(define-page "paste"
(lambda ()
(let ((paste-title "Untitled paste"))
(set-page-title! paste-title)
(with-request-variables ((nick (nonempty as-string))
(title (nonempty as-string))
(paste (nonempty as-string))
(id (nonempty as-string)))
(div (@ (id "content"))
((and id (not paste))
(cond ((fetch-paste id)
=> (lambda (p)
(set! paste-title (third (last p)))
(set-page-title! paste-title)
`(,(format-all-snippets p)
(div (@ (id "paste-footer"))
(h2 (@ (align "center"))
(a (@ (href ,(sprintf "~a?id=~a;annotate=t"
"Annotate this paste!"))))))
(else (bail-out "Could not find a paste with this id: " id))))
(if (and use-captcha?
(not (equal? ($ 'captcha-user-answer)
(and-let* ((hash ($ 'captcha-hash))
(captcha (alist-ref hash captchas equal?)))
(captcha-string captcha)))))
(bail-out "Wrong captcha answer.")
(let* ((nick (or nick "anonymous"))
(title (or title "no title"))
(time (current-seconds))
(hashsum (string->sha1sum
(conc nick title time paste)))
(url '())
(snippet (map
(lambda (i)
(if (and (string? i) (string-null? i))
(list nick title time paste))))
(if (string-null? paste)
(bail-out "I am not storing empty pastes.")
(cond ((fetch-paste id)
=> (lambda (p)
(let ((count (+ 1 (length (cdr p)))))
(update-paste id snippet)
(set! url
(conc "paste?id=" id "#a" count))))))
(else (insert-paste hashsum snippet)
(set! url
(make-pathname base-path
(string-append "paste?id=" hashsum)))))
(set! paste-title title)
(when ($ 'notify-irc) (notify nick title url))
(when use-captcha?
(set! captchas
(delete-and-refill-captchas captchas ($ 'captcha-hash))))
`((h2 (@ (align "center")) "Thanks for your paste!")
(p "Hi " ,nick ", thanks for pasting: " (em ,title) (br))
(p (@ (align "center"))
"Your paste can be reached with this url: "
(a (@ (href ,url)) ,url))))))))
(else (bail-out "I am not storing empty pastes."))))))))
css: (page-css)
method: '(get head post))
(define (convert-newlines text mode)
(and text
(irregex-replace/all "\r\n"
(case mode
((#:unix) "\n")
((#:dos) "\r\n")
(else (error "unknown newline mode " mode))))))
(define-page "raw"
(lambda ()
(awful-response-headers '((content-type "text/plain")))
(let* ((id ($ 'id))
(annotation ($ 'annotation as-number))
(paste (fetch-paste id)))
(or (and paste
(<= annotation (length paste))
,(convert-newlines (fifth (list-ref (reverse paste) annotation)) #:unix)))
,(convert-newlines paste #:unix))
(bail-out "Could not find a paste with id " id))))
no-template: #t)
(define (number-of-posts)
(let ((n ($db "select count(distinct(hash)) from pastes")))
(and n (caar n))))
(define-page "browse"
(lambda ()
(with-request-variables ((from as-number)
(to as-number))
(let* ((nposts (number-of-posts))
(from (if (and from (>= from 0) (<= from nposts)) from 0))
(to (if (and to (> to from) (<= to nposts)) to browsing-steps))
(older-to (min (+ to browsing-steps) nposts))
(older-from (+ from browsing-steps))
(newer-from (- from browsing-steps))
(newer-to (max (- to browsing-steps) browsing-steps))
(history-path (make-pathname base-path "browse")))
(div (@ (id "content"))
(h2 (@ (align "center")) "Browsing pastes")
(div (@ (id "browse-navigation")
(align "center"))
,(if (>= newer-from 0)
`(a (@ (href ,(sprintf "~a?from=~a;to=~a"
newer-from newer-to)))
"< newer")
"< newer")
" ... "
,(if (and (not (= to nposts)) (<= older-to nposts))
`(a (@ (href ,(sprintf "~a?from=~a;to=~a"
"older >")
"older >")
,(make-post-table browsing-steps offset: from))))))))
(define-page "about"
(lambda ()
(div (@ (id "content"))
(h2 "You have reached the CHICKEN scheme pasting service")
(p "These pages are maintained by the CHICKEN scheme
project team. Anyone that enters a correct CAPTCHA response is allowed
to post anything he likes. If you find objectionable content, feel
free to drop a mail at chicken-janitors <at> nongnu dot org")
(p "The source code for these pages is
distributed under a BSD license at C-Keen's "
(a (@ (href "")) "github repo"))
(p "Our thanks go to chandler for the famous "
(a (@ (href "")) "lisppaste") " "
(a (@ (href "")) "(cliki page)")
" bot and the same disclaimer applies:")
(p "Lisppaste pastes can be made by anyone at
any time. Imagine a fearsomely comprehensive disclaimer of
liability. Now fear, comprehensively."))))
title: "About Pastiche")
(define-page "captcha"
(lambda ()
(if audible-captcha?
((hash as-string))
((splitted (string-split hash "."))
(hash (car splitted))
(extension (or (null? (cdr splitted)) (cadr splitted))))
(cond ((and
(equal? extension "wav")
(alist-ref (car (string-split hash ".")) captchas equal?)) =>
(lambda (c)
(awful-response-headers '((content-type "audio/wav")))
`(literal ,(string-as-wav espeak-binary
(captcha-string c)
(preferred-languages (header-contents 'accept-language (request-headers (current-request))))))))
(else (bail-out "Wrong captcha hash, please reload the page and try again")))))
(bail-out "Audio captchas have been disabled in the configuration.")))
no-template: #t)
) ;; end define-app
) ;; end pastiche
) ;; end module
Jump to Line
Something went wrong with that request. Please try again.