Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

383 lines (343 sloc) 14.301 kB
(module pastiche (pastiche)
(import chicken scheme)
(use awful
colorize
html-utils
html-tags
miscmacros
simple-sha1
sql-de-lite
spiffy
tcp
awful-sql-de-lite
sql-de-lite
files
posix
data-structures
utils
extras
(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 ()
(list->string
(let loop ((n (+ min-captcha-len
(random (- max-captcha-len
min-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
(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 "http://paste.call-cc.org")
(use-captcha? #t)
(num-captchas 500)
(browsing-steps 15)
(awful-settings (lambda (_) (_))))
(parameterize ((app-root-path base-path))
(add-request-handler-hook!
'awful-paste
(lambda (path handler)
(when (string-prefix? base-path path)
(switch-to-sql-de-lite-database)
(parameterize ((app-root-path base-path)
(db-credentials db-file)
(page-css "http://wiki.call-cc.org/chicken.css"))
(awful-settings handler)))))
(define figlet-installed?
(handle-exceptions exn
#f
(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
(ignore-errors
(let ((stuff (sprintf "#chicken ~s pasted ~s ~a"
nick 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))))))
(define (fetch-last-pastes from to)
(let ((r ($db "select * from pastes order by time desc limit ?,?" values: (list from to))))
r))
(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"
(or
(tabularize (map format-row (fetch-last-pastes from n))
header: '("Nickname" "Title" "Date"))
(<p> "No pastes so far."))))
(define (navigation-links)
(<div> id: "menu"
(<ul>
(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:"))
(form
(++ (if use-captcha?
(hidden-input 'captcha-hash captcha-hash)
"")
(tabularize
(append
`(( "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))
(fits
(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: (if annotation? (->string count) "") (third s)))
(if annotation? " added " " pasted ") (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) "#" (->string count)))
"permalink")
" | "
(link (make-pathname base-path
(string-append "raw?id=" (first s) "&annotation=" (->string count)))
"raw")
" ] ")))
(define (format-all-snippets snippets)
(fold (let ((c (length snippets)))
(lambda (p s)
(set! c (sub1 c))
(++ (print-snippet p annotation?: (not (= c (- (length (car snippets)) 1))) count: c) s)))
""
snippets))
(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."))))
(paste-form))))
(navigation-links)))
title: "Pastiche: the Chicken Scheme pasting service")
(define-page "paste"
(lambda ()
(with-request-variables ((nick (nonempty as-string))
(title (nonempty as-string))
paste
id)
(html-page
(++
(<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))
"anonymous"
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 (length (cdr p))))
(update-paste id snippet)
(set! url (make-pathname
base-path
(++ "paste?id=" id "#" (->string count)))))))
(else (insert-paste hashsum snippet)
(set! url (++ "paste?id=" hashsum))))
(when ($ 'notify-irc) (notify nick title url))
(++ (<h1> "Thanks for your paste!")
"Hi " nick (<br>) "Thanks for pasting: " (<em> title) (<br>)
"Your paste can be reached with this url: " (link url url))))))
(cond ((fetch-paste id)
=> (lambda (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)))))
(navigation-links))
css: (page-css)
title: (conc "Pastes for " id))))
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)))
paste
(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 ()
(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")))
(html-page
(++ (<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))
(navigation-links)))))))
(define-page "about"
(lambda ()
(html-page
(++ (<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 "https://github.com/ckeen/pastiche" "github repo"))
(<p> "Our thanks go to chandler for the famous "
(link "http://paste.lisp.org" "lisppaste") " "
(link "http://www.cliki.net/lisppaste" "(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."))
(navigation-links))))))))
Jump to Line
Something went wrong with that request. Please try again.