#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/ ;; - scrbl for code is tmp//code.scrbl ;; - compiled code is tmp//code.html ;; -- if code scrbl file couldn't be compiled, then error is in ;; tmp//code.err ;; - scrbl for eval is tmp//eval.scrbl ;; - compiled eval is tmp//eval.html ;; -- if eval results in 1 pict: tmp//pict.png ;; -- if eval results in n picts: tmp//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-check-bindings request) (define bs (request-bindings request)) (if (and (andmap (λ (b) (exists-binding? b bs)) '(name g-recaptcha-response paste fork-from)) (implies (exists-binding? 'irc bs) (exists-binding? 'nick bs))) (check-paste request) (response/xexpr `(html () (head ()) (body () "ERROR: bad paste" ,(mk-link pastebin-url "Go Back")))))) (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] [("rest") #:method "post" check-paste-check-bindings] [("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".*")