770 lines
35 KiB
Racket
770 lines
35 KiB
Racket
#lang racket
|
|
|
|
(require web-server/servlet web-server/dispatch
|
|
web-server/http/request-structs)
|
|
(require xml xml/path net/url net/uri-codec json "recaptcha.rkt"
|
|
"spam.rkt")
|
|
(require racket/system racket/runtime-path)
|
|
(require redis data/ring-buffer)
|
|
(require "pasterack-utils.rkt" "pasterack-parsing-utils.rkt"
|
|
"pasterack-test-cases.rkt" "irc-bot.rkt")
|
|
|
|
(provide/contract (start (request? . -> . response?)))
|
|
|
|
(define-runtime-path htdocs-dir "htdocs")
|
|
(define-runtime-path here-dir ".")
|
|
(define-runtime-path tmp-dir "tmp")
|
|
|
|
;(define pastebin-url "http://162.243.38.241:8000/")
|
|
(define pastebin-url "http://pasterack.org/")
|
|
(define paste-url-base (++ pastebin-url "pastes/"))
|
|
(define racket-docs-url "http://docs.racket-lang.org/")
|
|
(define racket-lang-url "http://racket-lang.org")
|
|
(define racket-logo-url "http://racket-lang.org/logo.png")
|
|
(define racket-irc-url "https://botbot.me/freenode/racket/")
|
|
|
|
(define scrbl-exe "/home/pasterack/racket63/bin/scribble")
|
|
;(define scrbl-exe "/home/stchang/racket-6.2.0.3/bin/scribble")
|
|
|
|
(define PASTE-TITLE-DISPLAY-LEN 32) ; limit length of displayed title
|
|
|
|
(define (mk-paste-url paste-num) (++ paste-url-base paste-num))
|
|
|
|
;(define (mk-link url txt) `(a ((href ,url)) ,txt))
|
|
|
|
(define (fresh-str)
|
|
(with-redis-connection
|
|
(let loop () (define str (mk-rand-str)) (if (EXISTS str) (loop) str))))
|
|
|
|
;; logging
|
|
(define log-file (build-path here-dir "pasterack.log"))
|
|
(define log-port (open-output-file log-file #:mode 'text #:exists 'append))
|
|
|
|
(pasterack-irc-connect)
|
|
|
|
(define sample-pastes
|
|
'("8953" ; Sierpinski
|
|
"5563" ; Greek letters
|
|
"4837" ; lazy fib
|
|
"3259" ; scribble syntax
|
|
"8314" ; check-expect
|
|
"7435" ; #lang htdp/bsl + 2htdp/image
|
|
"3883" ; echo serv, test limits, and forms in racket but not racket/base
|
|
"7658" ; typed/racket
|
|
"97561"; plot
|
|
"29314"; fish pict
|
|
))
|
|
|
|
(define sample-pastes-htmls
|
|
(let ([ns (with-redis-connection
|
|
(do-MULTI (for ([p sample-pastes]) (send-cmd 'HGET p 'name))))])
|
|
(for/list ([name/bytes ns] [pnum sample-pastes])
|
|
(define name (bytes->string/utf-8 name/bytes))
|
|
`(tr (td ,(mk-link (mk-paste-url pnum) pnum))
|
|
(td ((style "width:1px"))) (td ,name)))))
|
|
|
|
(define NUM-RECENT-PASTES 16)
|
|
(define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES))
|
|
(for ([p test-cases]) (ring-buffer-push! recent-pastes p))
|
|
|
|
(define TR-bad-ids
|
|
(++ "#%module-begin with-handlers lambda λ #%top-interaction for for* "
|
|
"define default-continuation-prompt-tag struct case-lambda let-values "
|
|
"letrec-values for*/product let let* letrec define-struct for*/lists "
|
|
"for*/hasheqv let/cc do for/and for/sum for/hasheq for/lists for*/and "
|
|
"for*/hasheq for*/vector for/or for/hasheqv for*/last for*/or for/last "
|
|
"for*/sum for/first for*/fold for/product for/hash for*/list let/ec "
|
|
"for/list for/vector for*/hash for/fold for*/first let*-values"))
|
|
(define plai-bad-ids "#%module-begin provide")
|
|
|
|
;; returns generated pastenum
|
|
(define (write-codeblock-scrbl-file code pnum)
|
|
(define tmp-scrbl-file (build-path tmp-dir pnum (++ pnum "code.scrbl")))
|
|
(define-values (lang code-no-lang) (hashlang-split code))
|
|
(define lang-lst
|
|
(cond [(scribble-lang? lang) (list "racket" lang)]
|
|
[(htdp-lang? lang) (list (htdplang->modulename lang))]
|
|
[(or (TR-lang? lang) (plai-lang? lang)) (list)]
|
|
[(web-lang? lang) (list "web-server" "web-server/http")]
|
|
[else (list lang)]))
|
|
(define reqs
|
|
(with-handlers ([exn:fail? (const null)]) ;; read fail = non-sexp syntax
|
|
(with-input-from-string code-no-lang
|
|
(lambda () (for/list ([e (in-port)] #:when (require-datum? e))
|
|
(second (get-require-spec e)))))))
|
|
(define valid-reqs
|
|
(string-join
|
|
(map to-string/s
|
|
(filter
|
|
valid-req?
|
|
(append-map string->datums reqs)))))
|
|
|
|
(with-output-to-file tmp-scrbl-file
|
|
(lambda () (printf
|
|
(++ "#lang scribble/manual\n"
|
|
"@(require racket/require)\n"
|
|
"@(require (for-label "
|
|
(cond
|
|
[(TR-lang? lang)
|
|
(++ "(except-in typed/racket " TR-bad-ids ")\n"
|
|
"(only-meta-in 0 (only-in typed/racket " TR-bad-ids "))\n")]
|
|
[(plai-lang? lang)
|
|
(++ "(except-in plai " plai-bad-ids ")\n"
|
|
"(only-meta-in 0 (only-in plai " plai-bad-ids "))\n")]
|
|
[else ""])
|
|
;; when required id is also in lang, favor require
|
|
(cond
|
|
[(htdp-lang? lang)
|
|
(++ valid-reqs " "
|
|
"(subtract-in " (car lang-lst)
|
|
" (combine-in " valid-reqs "))")]
|
|
[else (++ valid-reqs " "
|
|
"(subtract-in (combine-in " (string-join lang-lst) ")"
|
|
" (combine-in " valid-reqs "))")])
|
|
"))\n"
|
|
"@codeblock|{\n~a}|")
|
|
code))
|
|
#:mode 'text
|
|
#:exists 'replace))
|
|
(define (write-eval-scrbl-file code pnum)
|
|
; parse out #lang if it's there, otherwise use racket
|
|
(define-values (lang code-no-lang) (hashlang-split code))
|
|
(define tmp-scrbl-file (build-path tmp-dir pnum (++ pnum "eval.scrbl")))
|
|
(define out (current-output-port))
|
|
(with-output-to-file tmp-scrbl-file
|
|
(lambda ()
|
|
(cond
|
|
;; htdp lang only --------------------------------------------------
|
|
[(htdp-lang? lang)
|
|
;; separate code into exprs and other things
|
|
;; - exprs get evaled by interaction (ow pictures dont work)
|
|
;; - other top-level defs get included in make-module-evaluator
|
|
;; because they are not allowed in interactions
|
|
(define-values (code-defs/checks code-exprs)
|
|
(partition not-htdp-expr? (string->datums code-no-lang)))
|
|
(define lang-name (htdplang->modulename lang))
|
|
(printf
|
|
(++ "#lang scribble/manual\n"
|
|
"@(require scribble/eval racket/sandbox)\n"
|
|
"@(define-namespace-anchor anchor)\n"
|
|
"@(define the-eval\n"
|
|
" (parameterize ([sandbox-output 'string]\n"
|
|
" [sandbox-error-output 'string]\n"
|
|
" [sandbox-propagate-breaks #f]\n"
|
|
" [sandbox-namespace-specs "
|
|
"(cons "
|
|
"(lambda () (namespace-anchor->namespace anchor)) "
|
|
"'(racket/pretty file/convertible))]\n"
|
|
" [sandbox-path-permissions "
|
|
"'([read \"/home/pasterack/pasterack/tmp/\"]\n"
|
|
;; images seem to need access to the prefs file
|
|
"[read \"/home/pasterack/.racket/\"]\n"
|
|
;; 2htdp/image performs exists? checks on libpng
|
|
"[exists \"/\"])]\n"
|
|
" [sandbox-eval-limits '(20 128)])\n"
|
|
" (let ([e (make-module-evaluator "
|
|
"'(module m " lang-name
|
|
" (require test-engine/racket-tests) "
|
|
(string-join (map to-string/s code-defs/checks))
|
|
" (test))"
|
|
")])\n"
|
|
" (call-in-sandbox-context e\n"
|
|
" (lambda ()\n"
|
|
" (current-print (dynamic-require 'racket/pretty "
|
|
"'pretty-print-handler))))\n"
|
|
" e)))\n"
|
|
"@interaction[#:eval the-eval\n"
|
|
(string-join (map to-string/s code-exprs))
|
|
" (test)]"))]
|
|
;; non htdp lang --------------------------------------------------
|
|
[else
|
|
(define datums (string->datums code-no-lang))
|
|
; (for ([d datums]) (fprintf out "~a\n" d))
|
|
(define-values (mod-datums expr-datums)
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
|
(eval `(require ,(string->symbol lang)))
|
|
(partition (lambda (d) (not-expr? d out)) datums)))
|
|
; (fprintf out "~a\n" (string-join (map to-string/s mod-datums)))
|
|
; (fprintf out "~a\n" (string-join (map to-string/s expr-datums)))
|
|
(display
|
|
; (printf
|
|
(++ "#lang scribble/manual\n"
|
|
"@(require scribble/eval racket/sandbox)\n"
|
|
"@(define-namespace-anchor anchor)\n"
|
|
"@(define the-eval\n"
|
|
" (parameterize ([sandbox-output 'string]\n"
|
|
" [sandbox-error-output 'string]\n"
|
|
" [sandbox-propagate-breaks #f]\n"
|
|
" [sandbox-namespace-specs "
|
|
"(cons "
|
|
"(lambda () (namespace-anchor->namespace anchor)) "
|
|
"'(racket/pretty file/convertible))]\n"
|
|
" [sandbox-path-permissions "
|
|
"'([read \"/home/pasterack/pasterack/tmp/\"]"
|
|
"[read \"/home/pasterack/.racket/\"]\n"
|
|
;; 2htdp/image performs exists? checks on libpng
|
|
"[exists \"/\"])]\n"
|
|
" [sandbox-eval-limits '(20 128)])\n"
|
|
; " (let ([e (make-evaluator '" lang ")])\n"
|
|
" (let ([e (make-module-evaluator "
|
|
"'(module m " lang "\n"
|
|
(string-join (map to-string/s mod-datums))
|
|
"))])\n"
|
|
" (call-in-sandbox-context e\n"
|
|
" (lambda ()\n"
|
|
" (current-print (dynamic-require 'racket/pretty "
|
|
"'pretty-print-handler))))\n"
|
|
" e)))\n"
|
|
;; "@interaction[#:eval the-eval\n~a]")
|
|
;; code-no-lang)]))
|
|
"@interaction[#:eval the-eval\n(void)\n"
|
|
(string-join (map to-string/s expr-datums))
|
|
"]")
|
|
)]))
|
|
#:mode 'text
|
|
#:exists 'replace))
|
|
|
|
(define (compile-scrbl-file/get-html pnum)
|
|
(define new-tmpdir (build-path tmp-dir pnum))
|
|
(define err (open-output-file (build-path new-tmpdir (++ pnum "code.err"))))
|
|
(define scrbl-file (build-path new-tmpdir (++ pnum "code.scrbl")))
|
|
(define html-file (build-path new-tmpdir (++ pnum "code.html")))
|
|
(and (parameterize ([current-error-port err])
|
|
(begin0 (system (++ scrbl-exe " --html "
|
|
"+m --redirect-main " racket-docs-url " "
|
|
"--dest " (path->string new-tmpdir) " "
|
|
(path->string scrbl-file)))
|
|
(close-output-port err)))
|
|
(with-input-from-file html-file port->bytes)))
|
|
(define (compile-eval-scrbl-file/get-html pnum)
|
|
(define new-tmpdir (build-path tmp-dir pnum))
|
|
(define scrbl-file (build-path new-tmpdir (++ pnum "eval.scrbl")))
|
|
(define html-file (build-path new-tmpdir (++ pnum "eval.html")))
|
|
(and (system (++ scrbl-exe " --html "
|
|
"--dest " (path->string new-tmpdir) " "
|
|
(path->string scrbl-file)))
|
|
(with-input-from-file html-file port->bytes)))
|
|
|
|
;; files/directories layout ---------------------------------------------------
|
|
;; web-server files are in htdocs/
|
|
;; each paste creates a directory tmp/<pastenum>
|
|
;; - scrbl for code is tmp/<pastenum>/<pastenum>code.scrbl
|
|
;; - compiled code is tmp/<pastenum>/<pastenum>code.html
|
|
;; -- if code scrbl file couldn't be compiled, then error is in
|
|
;; tmp/<pastenum>/<pastenum>code.err
|
|
;; - scrbl for eval is tmp/<pastenum>/<pastenum>eval.scrbl
|
|
;; - compiled eval is tmp/<pastenum>/<pastenum>eval.html
|
|
;; -- if eval results in 1 pict: tmp/<pastenum>/pict.png
|
|
;; -- if eval results in n picts: tmp/<pastenum>/pict_1.png through pict_n.png
|
|
|
|
(define (generate-paste-html code pastenum)
|
|
(define paste-dir (build-path tmp-dir pastenum))
|
|
(unless (directory-exists? paste-dir) (make-directory paste-dir))
|
|
(write-codeblock-scrbl-file code pastenum)
|
|
(compile-scrbl-file/get-html pastenum))
|
|
(define (generate-eval-html code pastenum)
|
|
;; should check that tmp/pastenum dir exists here
|
|
(write-eval-scrbl-file code pastenum)
|
|
(compile-eval-scrbl-file/get-html pastenum))
|
|
|
|
(define google-analytics-script
|
|
(++ "var _gaq = _gaq || [];\n"
|
|
"_gaq.push(['_setAccount', 'UA-44480001-1']);\n"
|
|
"_gaq.push(['_trackPageview']);\n"
|
|
"(function() {\n"
|
|
"var ga = document.createElement('script'); "
|
|
"ga.type = 'text/javascript'; ga.async = true;\n"
|
|
"ga.src = ('https:' == document.location.protocol "
|
|
"? 'https://ssl' : 'http://www') + '.google-analytics.com/ga.js';\n"
|
|
"var s = document.getElementsByTagName('script')[0];"
|
|
"s.parentNode.insertBefore(ga, s);\n"
|
|
"})();"))
|
|
(define twitter-script
|
|
(++ "!function(d,s,id){"
|
|
"var js,fjs=d.getElementsByTagName(s)[0],"
|
|
"p=/^http:/.test(d.location)?'http':'https';"
|
|
"if(!d.getElementById(id)){"
|
|
"js=d.createElement(s);js.id=id;"
|
|
"js.src=p+'://platform.twitter.com/widgets.js';"
|
|
"fjs.parentNode.insertBefore(js,fjs);}}"
|
|
"(document, 'script', 'twitter-wjs');"))
|
|
|
|
(define codemirror-script
|
|
"var codeMirror = CodeMirror.fromTextArea(document.getElementById(\"paste\"),\
|
|
{ lineNumbers : true, matchBrackets : true, theme: \"neat\" }
|
|
);")
|
|
|
|
(define droidsansmono-css/x
|
|
'(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://fonts.googleapis.com/css?family=Droid+Sans+Mono"])))
|
|
(define ptsans-css/x
|
|
'(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://fonts.googleapis.com/css?family=PT+Sans"])))
|
|
(define scrbl-css/x
|
|
'(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://pasterack.org/scribble.css"])))
|
|
(define scrbl-style-css/x
|
|
'(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://pasterack.org/scribble-style.css"])))
|
|
(define rkt-css/x
|
|
'(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://pasterack.org/racket.css"])))
|
|
|
|
|
|
;; generate SUBMIT button image
|
|
;; (require images/icons/control)
|
|
;; (require images/icons/style)
|
|
;; (require pict racket/draw)
|
|
;; (send
|
|
;; (pict->bitmap
|
|
;; (cc-superimpose
|
|
;; (bitmap (record-icon #:color (make-object color% 64 64 255) #:height 64
|
|
;; #:material glass-icon-material))
|
|
;; (bitmap (play-icon #:color light-metal-icon-color #:height 32
|
|
;; #:material metal-icon-material))))
|
|
;; save-file "htdocs/submit.png" 'png)
|
|
|
|
(define-syntax-rule (~~ prop ...) (string-join (list prop ...) ";"))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; serve home -----------------------------------------------------------------
|
|
(define (serve-home request #:title [title ""]
|
|
#:content [content "#lang racket"]
|
|
#:fork-from [fork-from ""]
|
|
#:status [status ""])
|
|
(define (response-generator embed/url)
|
|
(response/xexpr
|
|
`(html ([style ,(~~ "background-image:url('/plt-back.1024x768.png')"
|
|
"background-attachment:fixed"
|
|
"background-size:cover")])
|
|
;; head ----------------------------------------------------------------
|
|
(head
|
|
; (title "PasteRack (MIRROR): A Racket-evaluating pastebin")
|
|
(title "PasteRack: A Racket-evaluating pastebin")
|
|
(script ([type "text/javascript"]) ,google-analytics-script)
|
|
(script ([src "https://www.google.com/recaptcha/api.js"]))
|
|
,droidsansmono-css/x ,ptsans-css/x
|
|
;; expects a codemirror.js script and its scheme mode in htdocs
|
|
(script ([src "/codemirror.js"] [type "text/javascript"]))
|
|
(link ((rel "stylesheet") (href "/codemirror.css")))
|
|
(link ((rel "stylesheet") (href "/neat.css")))
|
|
(style ,(string-append ".CodeMirror { text-align: left; background: #FFFFF0;"
|
|
" font-size: 15px; height: 35em;"
|
|
" font-family: Droid Sans Mono, monospace;"
|
|
" border: thin gray inset; width: 50em; }"))
|
|
)
|
|
;; body ----------------------------------------------------------------
|
|
(body ((style "font-family:'PT Sans',sans-serif"))
|
|
; (h1 "MIRROR")
|
|
;; left --------------------------------------------------------------
|
|
(div ((style ,(~~ "position:absolute;left:1em;top:2em"
|
|
"width:12em"
|
|
"font-size:95%")))
|
|
(h4 "Total pastes: " ,(number->string (DBSIZE)))
|
|
(h4 "Sample pastes:")
|
|
(table ((style "margin-top:-15px;font-size:95%"))
|
|
,@sample-pastes-htmls)
|
|
(h4 "Recent pastes:")
|
|
(table ((style "margin-top:-15px;font-size:95%"))
|
|
,@(reverse
|
|
(with-redis-connection
|
|
(for/list ([pnum recent-pastes] #:when pnum
|
|
#:when (HGET/str pnum 'name))
|
|
(define name (HGET/str pnum 'name))
|
|
(define trunc-name
|
|
(string-truncate name PASTE-TITLE-DISPLAY-LEN))
|
|
`(tr (td ,(mk-link (mk-paste-url pnum) pnum))
|
|
(td ((style "width:1px"))) (td ,trunc-name)))))))
|
|
;; middle ------------------------------------------------------------
|
|
(div ((style ,(~~ "position:absolute;left:14em;top:2em")))
|
|
(center
|
|
(img ((src ,racket-logo-url)))
|
|
(h2 ,(mk-link pastebin-url "PasteRack")
|
|
": An evaluating pastebin for "
|
|
,(mk-link racket-lang-url "Racket") ".")
|
|
(form ([action ,(embed/url check-paste)] [method "post"])
|
|
(div
|
|
(input ([type "text"] [name "name"] [size "60"] [value ,title]
|
|
[style ,(~~ "background-color:#FFFFF0"
|
|
"border:inset thin"
|
|
"font-size:105%"
|
|
"font-family:'PT Sans',sans-serif")]))
|
|
(span ([style "font-size:90%"]) " (paste title)"))
|
|
(br)
|
|
(textarea ([id "paste"] [name "paste"]) ,content)
|
|
;; run script after textarea is evaluated
|
|
(script ([type "text/javascript"]) ,codemirror-script)
|
|
(input ([type "hidden"] [name "fork-from"] [value ,fork-from]))
|
|
(br)
|
|
(table (tr
|
|
(td ((style "width:18em")))
|
|
;; submit button -------------
|
|
(td ((style "width:5em"))
|
|
(input ([type "image"] [alt "Submit Paste and Run"]
|
|
[src "/submit.png"])))
|
|
;; paste to irc --------------
|
|
(td ((style "font-size:90%"))
|
|
(input ([type "checkbox"] [name "irc"] [value "off"]))
|
|
(span " Alert "
|
|
,(mk-link racket-irc-url "#racket") "; your nick: ")
|
|
(input ([type "text"] [name "nick"] [size "10"]
|
|
[style ,(~~ "background-color:#FFFFF0"
|
|
"border:inset thin"
|
|
"font-size:105%"
|
|
"font-family:'PT Sans',sans-serif")])))))
|
|
(span ,status)
|
|
(br)
|
|
(span ,(if (string=? "" fork-from) ""
|
|
`(span "Forked from paste # "
|
|
,(mk-link
|
|
(++ paste-url-base fork-from) fork-from))))
|
|
(br)
|
|
(div ([class "g-recaptcha"]
|
|
[data-sitekey "6LdM0wYTAAAAAJPls_eNV28XvCRMeaf1cDoAV4Qx"])
|
|
"To paste as plaintext, check the box:"))
|
|
(br)(br)(br)
|
|
;; middle bottom (part of middle) ------------------------------------
|
|
(div ([style "font-size:small;color:#808080"])
|
|
"Powered by " ,(mk-link racket-lang-url "Racket") ". "
|
|
"View "
|
|
,(mk-link "https://github.com/stchang/pasterack" "source") "."
|
|
" Report issues or suggestions "
|
|
,(mk-link "https://github.com/stchang/pasterack/issues" "here") ". "
|
|
"Inspired by "
|
|
,(mk-link "https://github.com/samth/paste.rkt" "paste.rkt") "."
|
|
)
|
|
))
|
|
))))
|
|
(send/suspend/dispatch response-generator))
|
|
|
|
(define (check-paste request)
|
|
(define bs (request-bindings request))
|
|
(define name (extract-binding/single 'name bs))
|
|
(define captcha-token (extract-binding/single 'g-recaptcha-response bs))
|
|
(define paste-content (extract-binding/single 'paste bs))
|
|
(define fork-from (extract-binding/single 'fork-from bs))
|
|
(define-values (status headers captcha-success-in)
|
|
(http-sendrecv/url
|
|
(string->url "https://www.google.com/recaptcha/api/siteverify")
|
|
#:method "POST"
|
|
#:data (alist->form-urlencoded
|
|
(list (cons 'secret RECAPTCHA-SECRET)
|
|
(cons 'response captcha-token)
|
|
(cons 'remoteip (request-client-ip request))))
|
|
#:headers '("Content-Type: application/x-www-form-urlencoded")))
|
|
(define as-text? (hash-ref (read-json captcha-success-in) 'success #f))
|
|
;; very basic spam filter TODO: move check to client-side?
|
|
(if (and ;; probably spam
|
|
(or (not as-text?)
|
|
(check-ip (request-client-ip request)))
|
|
(not (has-hashlang? paste-content)))
|
|
(serve-home request
|
|
#:title name
|
|
#:content paste-content
|
|
#:fork-from fork-from
|
|
#:status '(span "Invalid paste: must include #lang." (br)
|
|
"Or check the box to paste as plaintext."))
|
|
(process-paste request as-text?)))
|
|
|
|
(define (process-paste request [as-text? #f])
|
|
(define bs (request-bindings request))
|
|
(cond
|
|
[(exists-binding? 'paste bs)
|
|
(define paste-num (fresh-str))
|
|
(define paste-name (extract-binding/single 'name bs))
|
|
(define pasted-code (extract-binding/single 'paste bs))
|
|
(define fork-from (extract-binding/single 'fork-from bs))
|
|
(define html-res
|
|
(if as-text? #f (generate-paste-html pasted-code paste-num)))
|
|
(define paste-html-str (or html-res pasted-code))
|
|
(define eval-html-str
|
|
(if html-res
|
|
;; eval only if able to read pasted code
|
|
(generate-eval-html pasted-code paste-num)
|
|
;; if not, use read error as output,
|
|
;; unless as-text was explicitly checked
|
|
(if as-text? #f
|
|
(with-input-from-file
|
|
(build-path tmp-dir paste-num (++ paste-num "code.err"))
|
|
port->string))))
|
|
(define paste-url (mk-paste-url paste-num))
|
|
(ring-buffer-push! recent-pastes paste-num)
|
|
(define tm-str (get-time/iso8601))
|
|
(SET/hash paste-num (hash 'name paste-name
|
|
'code pasted-code
|
|
'code-html paste-html-str
|
|
'eval-html (or eval-html-str "")
|
|
'time tm-str
|
|
'fork-from fork-from
|
|
'views 0))
|
|
(when (exists-binding? 'irc bs)
|
|
(define nick (extract-binding/single 'nick bs))
|
|
(irc-paste (++ (if (string=? "" nick) "" (++ nick " pasted: "))
|
|
(if (string=? "" paste-name) "" (++ paste-name ", "))
|
|
paste-url)))
|
|
(fprintf log-port "~a\t~a\t~a\t~a\n"
|
|
tm-str paste-num paste-name (request-client-ip request))
|
|
(redirect-to paste-url permanently)]
|
|
[else
|
|
(response/xexpr
|
|
`(html ()
|
|
(head ())
|
|
(body () "ERROR: bad paste" ,(mk-link pastebin-url "Go Back"))))]))
|
|
|
|
(define (get-main-div html-bytes)
|
|
(with-handlers ([exn:fail? (lambda (x) (bytes->string/utf-8 html-bytes))])
|
|
(car (filter
|
|
(lambda (d) (equal? "main" (se-path* '(div #:class) d)))
|
|
(se-path*/list '(div)
|
|
(xml->xexpr (document-element
|
|
(with-input-from-bytes html-bytes read-xml))))))))
|
|
|
|
(define (serve-paste request pastenum)
|
|
(define retrieved-paste-hash
|
|
(with-redis-connection
|
|
(when (HEXISTS pastenum 'views) (HINCRBY pastenum 'views 1))
|
|
(GET/hash pastenum #:map-key bytes->symbol)))
|
|
(cond
|
|
[(equal? (hash) retrieved-paste-hash)
|
|
(response/xexpr
|
|
`(html() (head (title "Paste not found"))
|
|
(body ()
|
|
,(format "Paste # ~a doesn't exist." pastenum) (br)
|
|
,(mk-link pastebin-url "Go Back"))))]
|
|
[else
|
|
(define-values (name code code-html eval-html time-str fork-from views)
|
|
(match retrieved-paste-hash
|
|
[(hash-table ('name paste-name) ('code code) ('code-html code-html)
|
|
('eval-html eval-html) ('time time-str)
|
|
('fork-from fork-from) ('views views))
|
|
(values (bytes->string/utf-8 paste-name)
|
|
(bytes->string/utf-8 code)
|
|
code-html eval-html
|
|
(bytes->string/utf-8 time-str)
|
|
(bytes->string/utf-8 fork-from)
|
|
(bytes->string/utf-8 views))]
|
|
;; old record layouts
|
|
[(hash-table ('name paste-name) ('code code-html)
|
|
('eval eval-html) ('time time-str))
|
|
(values (bytes->string/utf-8 paste-name)
|
|
"" code-html eval-html
|
|
(bytes->string/utf-8 time-str) "" "")]))
|
|
(define code-main-div (get-main-div code-html))
|
|
(define eval-main-div (get-main-div eval-html))
|
|
(define paste-url (string-append paste-url-base pastenum))
|
|
|
|
;; move-image-file: html -> html
|
|
;; '(img ((alt "image") ,height (src ,filename) ,width))
|
|
;; =>
|
|
;; '(img ((alt "image") ,height (src ,new-filename) ,width))
|
|
;; side effect: moves pict file from tmp dir to permanent location in htdocs
|
|
(define (move-image-file filename height width
|
|
[style '(style "")])
|
|
;; rename file to avoid future clashes
|
|
(define rxmatch
|
|
(regexp-match #px"^(pict|\\d+)\\_*(\\d+)*\\.png"
|
|
filename))
|
|
(unless rxmatch
|
|
(error "scribble made non-pict.png ~a" filename))
|
|
(match-define (list _ base offset) rxmatch)
|
|
(define new-file
|
|
(++ pastenum (if offset (++ "_" offset) "") ".png"))
|
|
(define curr-file-path
|
|
(build-path tmp-dir pastenum filename))
|
|
(define new-file-path
|
|
(build-path htdocs-dir new-file))
|
|
(unless (file-exists? new-file-path)
|
|
(copy-file curr-file-path new-file-path)
|
|
(delete-file curr-file-path))
|
|
`(img ((alt "image")
|
|
,height (src ,(++ pastebin-url new-file)) ,style ,width)))
|
|
;; should be a flat list of elems, even for nested lists
|
|
(define (move-image-files lst)
|
|
(for/list ([elem lst])
|
|
(match elem
|
|
;; 611 added a "style" field
|
|
[`(img ((alt "image") ,height (src ,filename) ,style ,width))
|
|
(move-image-file filename height width style)]
|
|
[`(img ((alt "image") ,height (src ,filename) ,width))
|
|
(move-image-file filename height width)]
|
|
[x x])))
|
|
(define main-html
|
|
(match code-main-div
|
|
[`(div ((class "main")) ,ver
|
|
(blockquote ((class "SCodeFlow"))
|
|
(table ,table-params . ,rows)))
|
|
(define new-rows
|
|
(map
|
|
(lambda (r)
|
|
(match r
|
|
[`(tr () (td () . ,rst))
|
|
`(li (span ((style "font-family:'Droid Sans Mono',monospace;font-size:125%")) . ,rst))]
|
|
[_ r]))
|
|
rows))
|
|
; `(div ;((class "main"))
|
|
`(div ([style ,(~~ "font-family:'Droid Sans Mono',monospace"
|
|
"background-color:transparent")])
|
|
; (blockquote ;((class "SCodeFlow"))
|
|
(ol ((start "0")(style "font-size:70%;color:#A0A0A0"))
|
|
. ,new-rows)
|
|
(p "=>")
|
|
,(match eval-main-div
|
|
[`(div ((class "main")) ,ver
|
|
(blockquote ,attr1 (table ,attr2 . ,results)))
|
|
; `(blockquote ,attr1 (table ,attr2 .
|
|
`(blockquote (table ([style ,(~~ "font-size:90%"
|
|
"table-layout:fixed"
|
|
"width:100%"
|
|
"word-wrap:break-word")]) .
|
|
,(filter
|
|
identity
|
|
(map ; either rewrites html or produces #f to be filtered
|
|
(lambda (x)
|
|
(match x
|
|
;; single-line evaled expr (with ">" prompt), skip
|
|
[`(tr () (td () (span ((class "stt")) ">" " ") . ,rst))
|
|
#f]
|
|
;; multi-line evaled expr
|
|
[`(tr () (td ()
|
|
(table ((cellspacing "0")
|
|
(class "RktBlk"))
|
|
(tr () (td () (span ((class "stt")) ">" " ")
|
|
. ,rst1)) . ,rst))) #f]
|
|
;; void result, skip
|
|
[`(tr () (td () (table ,attr (tr () (td ()))))) #f]
|
|
;; rewrite filename in image link (1st case):
|
|
;; html of img output (for pict) has changed (in 611?)
|
|
;; new "style" field added, so handle as separate case
|
|
[`(tr () (td () (p ()
|
|
(img ((alt "image")
|
|
,height (src ,filename) ,style ,width)))))
|
|
;; renames file to avoid future clashes
|
|
;; and rewrites html with new filename
|
|
`(tr () (td () (p ()
|
|
,(move-image-file filename height width style))))]
|
|
;; fix filename in image link (2nd case)
|
|
;; (this was the only case before 611)
|
|
[`(tr () (td () (p ()
|
|
(img ((alt "image") ,height (src ,filename) ,width)))))
|
|
;; renames file to avoid future clashes
|
|
;; and rewrites html with new filename
|
|
`(tr () (td () (p ()
|
|
,(move-image-file filename height width))))]
|
|
;; list(s) of images
|
|
[`(tr () (td () (p ()
|
|
(span ((class "RktRes")) "'(") . ,rst)))
|
|
`(tr () (td () (p ()
|
|
(span ((class "RktRes")) "'(")
|
|
,@(move-image-files rst))))]
|
|
;; nested table
|
|
[`(tr () (td () (table ,attrs . ,rows)))
|
|
`(tr () (td () (table ([style ,(~~ "font-size:95%"
|
|
"table-layout:fixed"
|
|
"width:100%"
|
|
"word-wrap:break-word")])
|
|
. ,rows)))]
|
|
[x x]))
|
|
results))))]
|
|
[_ `(div (pre ,eval-main-div))]))]
|
|
[_ `(div (pre ,code-main-div)
|
|
,(if (string=? eval-main-div "") ""
|
|
`(span (p "=>") (pre ,eval-main-div)))
|
|
)]))
|
|
(serve-home #:content code #:title name #:fork-from pastenum
|
|
(send/suspend
|
|
(lambda (home-url)
|
|
(response/xexpr
|
|
`(html ([style ,(~~ "background-image:url('/plt-back.1024x768.png')"
|
|
"background-attachment:fixed"
|
|
"background-size:cover")])
|
|
(head ()
|
|
(meta ((content "text-html; charset=utf-8")
|
|
(http-equiv "content-type")))
|
|
(title ,(++ "Paste # " pastenum ": " name))
|
|
,scrbl-css/x ,rkt-css/x ,scrbl-style-css/x
|
|
,droidsansmono-css/x ,ptsans-css/x
|
|
(script ((src "/scribble-common.js") (type "text/javascript")))
|
|
(script ,twitter-script))
|
|
(body ([style ,(~~ "font-family:'PT Sans',sans-serif"
|
|
"background-color:transparent")])
|
|
;; left ----------------------------------------------------------------
|
|
(div ([style "position:absolute;left:1em;top:2em"])
|
|
(table ([cellspacing "0"] [cellpadding "0"])
|
|
(tr (td ,(mk-link pastebin-url "PasteRack.org")))
|
|
(tr (td ((height "10px"))))
|
|
(tr (td "Paste # " (a ((href ,paste-url)) ,pastenum)))
|
|
(tr (td ([colspan "3"] [style "font-size:90%"]) ,time-str))
|
|
(tr (td ,(if (string=? "" fork-from) ""
|
|
`(span (br) "Forked from paste # "
|
|
,(mk-link (++ paste-url-base fork-from) fork-from)
|
|
"."))))
|
|
(tr (td
|
|
,(if (string=? "" code) ""
|
|
`(span (br) (a ([href ,home-url]) "Fork") " as a new paste."))))
|
|
(tr (td ,(if (string=? "" views) ""
|
|
`(span (br) "Paste viewed " ,views " time"
|
|
,(if (string=? "1" views) "." "s.")))))
|
|
(tr (td (br)
|
|
(a ([href "https://twitter.com/share"][class "twitter-share-button"]
|
|
[data-related "racketlang"][data-dnt "true"]) "Tweet")))
|
|
(tr (td (br) "Embed:"))
|
|
(tr (td (textarea ([rows "2"][cols "16"])
|
|
,(xexpr->string scrbl-css/x)
|
|
,(xexpr->string rkt-css/x)
|
|
,(xexpr->string droidsansmono-css/x)
|
|
,(xexpr->string main-html))))))
|
|
;; middle --------------------------------------------------------------
|
|
(div ((style "position:absolute;left:14em"))
|
|
,(if (string=? name "") '(br) `(h4 ,name))
|
|
,main-html)))))) )]))
|
|
|
|
(define (serve-tests request)
|
|
(define test-cases-htmls
|
|
(let ([ns (with-redis-connection
|
|
(do-MULTI (for ([p test-cases]) (send-cmd 'HGET p 'name))))])
|
|
(for/list ([name/bytes ns] [pnum test-cases])
|
|
(define name (bytes->string/utf-8 name/bytes))
|
|
`(tr (td ,(mk-link (mk-paste-url pnum) pnum))
|
|
(td ((style "width:1px"))) (td ,name)))))
|
|
(response/xexpr
|
|
`(html ([style ,(~~ "background-image:url('/plt-back.1024x768.png')"
|
|
"background-attachment:fixed"
|
|
"background-size:cover")])
|
|
;; head ----------------------------------------------------------------
|
|
(head
|
|
(title "PasteRack: Test Cases")
|
|
(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://fonts.googleapis.com/css?family=PT+Sans"]))
|
|
(link ([type "text/css"] [rel "stylesheet"]
|
|
[href "http://fonts.googleapis.com/css?family=Droid+Sans+Mono"])))
|
|
;; body ----------------------------------------------------------------
|
|
(body ((style "font-family:'PT Sans',sans-serif"))
|
|
(div ((style ,(~~ "position:absolute;left:1em;top:2em"
|
|
"width:20em"
|
|
"font-size:95%")))
|
|
(h4 "Test Cases:")
|
|
(table ((style "margin-top:-15px;font-size:95%"))
|
|
,@test-cases-htmls))))))
|
|
|
|
(require "plt-bacon.rkt")
|
|
(define-values (do-dispatch mk-url)
|
|
(dispatch-rules
|
|
[("") serve-home]
|
|
[("pastes" (string-arg)) serve-paste]
|
|
[("tests") serve-tests]
|
|
[("bacon") serve-bacon]
|
|
#;[else serve-home]))
|
|
|
|
|
|
(define (start request) (do-dispatch request))
|
|
|
|
(require web-server/servlet-env)
|
|
(serve/servlet start
|
|
#:launch-browser? #f
|
|
#:quit? #f
|
|
#:listen-ip #f
|
|
#:port 8000
|
|
#:extra-files-paths (list htdocs-dir)
|
|
#:servlet-path "/"
|
|
#:servlet-regexp #rx".*")
|