Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…
Cannot retrieve contributors at this time
393 lines (352 sloc) 17.2 KB
(module pastiche (pastiche)
(import chicken scheme)
(use awful
(srfi 1 13))
;;; Captchas
(define-record captcha string figlet)
(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))))
;;; Pastiche
(define (pastiche base-path db-file
#!key (vandusen-port 22722)
(vandusen-host "localhost")
(base-url "")
(use-captcha? #t)
(num-captchas 500)
(browsing-steps 15)
(awful-settings (lambda (_) (_))))
(parameterize ((app-root-path base-path))
(lambda (path handler)
(when (string-prefix? base-path path)
(parameterize ((app-root-path base-path)
(db-credentials db-file)
(page-css ""))
(awful-settings handler)))))
(define figlet-installed?
(handle-exceptions exn
(system* "figlet -v 2>&1 > /dev/null")))
(when (and use-captcha? (not figlet-installed?))
(print "WARNING: `use-captcha?' indicates that captchas are enabled but figlet "
"doesn't seem to be installed. Disabling captchas.")
(set! use-captcha? #f))
(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 from to)
(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 from to))))
(define (make-post-table n #!optional (from 0))
(define (format-row r)
(list (second r) ; Nickname
(link (make-pathname base-path (string-append "/paste?id=" (first r)))
(third r)) ; title
(prettify-time (fourth r)))) ;date
(<div> class: "paste-table"
(tabularize (map format-row (fetch-last-pastes from n))
header: '("Nickname" "Title" "Date"))
(<p> "No pastes so far."))))
(define (navigation-links)
(<div> id: "menu"
(apply ++ (map (lambda (m)
(<li> (link (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:"))
(++ (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 vandusen-host
(<input> name: "notify-irc"
type: "checkbox"
checked: "checked"
"Please notify the #chicken channel on freenode.")
,(list (if annotate-id (hidden-input 'id annotate-id) "")
(submit-input value: "Submit paste!"))))))
action: (make-pathname base-path "paste")
method: "post"))))
(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") (<br>)
(<div> id: "failure-reason" (fold (lambda (i r)
(++ r (sprintf "~a" 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" (html-colorize 'scheme (fifth s)))))
(<div> class: "paste-footer"
" [ "
(link (make-pathname base-path
(string-append "paste?id=" (first s) "#a" (->string count)))
" | "
(link (make-pathname base-path
(string-append "raw?id=" (first s) "&annotation=" (->string 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) s)))
(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 handle-paste
(lambda ()
(let ((paste-title "Untitled paste"))
(with-request-variables ((nick (nonempty as-string))
(title (nonempty as-string))
(<div> id: "content"
(or (and-let* ((nick (or (and nick (htmlize nick)) "anonymous"))
(title (or (and title (htmlize title)) "no title"))
(time (current-seconds))
(paste (and (not (equal? "" paste)) paste))
(hashsum (string->sha1sum
(++ nick title (->string time) paste)))
(url '())
(snippet (map
(lambda (i)
(if (and (string? i) (string-null? i))
(list nick title time paste))))
(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.")
(if (string-null? paste)
(bail-out "I am not storing empty pastes.")
(begin (cond ((fetch-paste id)
=> (lambda (p)
(let ((count (+ 1 (length (cdr p)))))
(update-paste id snippet)
(set! url (make-pathname
(++ "paste?id=" id "#a" (->string count)))))))
(else (insert-paste hashsum snippet)
(set! url (make-pathname base-path (++ "paste?id=" hashsum)))))
(set! paste-title title)
(when ($ 'notify-irc) (notify nick title url))
(++ (<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: " (link url url))))))
(cond ((fetch-paste id)
=> (lambda (p)
(set! paste-title (third (last p)))
(format-all-snippets p)
(<div> id: "paste-footer"
(<h2> align: "center"
(link (++ base-path "?id=" id
";annotate=t") "Annotate this paste!"))))))
(else (bail-out "Could not find a paste with this id:" id)))))
css: (page-css)
title: paste-title)))))
(define-page "paste" handle-paste method: 'POST no-template: #t)
(define-page "paste" handle-paste method: 'GET no-template: #t)
(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 (<= annotation (length paste)) (fifth (list-ref (reverse paste) annotation)))
(bail-out "Could not find a paste with id " id))))
no-template: #t)
(define (number-of-posts)
(let ((n ($db "select count(hash) from pastes")))
(and n (caar n))))
(define-page "browse"
(lambda ()
((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) (link (sprintf "~a?from=~a;to=~a" history-path newer-from newer-to)
"< newer")
"< newer")
" ... "
(if (and (not (= to nposts)) (<= older-to nposts))
(link (sprintf "~a?from=~a;to=~a" history-path older-from older-to)
"older >")
"older >"))
(make-post-table to from))
(define-page "about"
(lambda ()
(++ (<div> id: "content"
(<h2> "You have reached the CHICKEN scheme pasting service")
(<p> (htmlize "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 "
(link "" "github repo"))
(<p> "Our thanks go to chandler for the famous "
(link "" "lisppaste") " "
(link "" "(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."))
Jump to Line
Something went wrong with that request. Please try again.