suzanne.soy/pasterack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

switch from make-base-eval to make-evaluator

Browse Source 
- move recent pastes to left side
- add sample pastes to left side
- add sandbox limit

closes #1, closes #9
This commit is contained in:
Stephen Chang 2013-10-03 03:16:27 -04:00
parent 115be05f1a
commit e8694e1602
1 changed files with 110 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
pasterack.rkt
View File

@ -28,21 +28,44 @@
(define (fresh-str) (define (fresh-str)
(let loop () (define str (mk-rand-str)) (if (EXISTS str) (loop) str))) (let loop () (define str (mk-rand-str)) (if (EXISTS str) (loop) str)))
(define NUM-RECENT-PASTES 10)
(define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES))
;; initialize buffer with some pastes ;; initialize buffer with some pastes
(ring-buffer-push! recent-pastes "4557") ; Sierpinski ;; (ring-buffer-push! recent-pastes "4557") ; Sierpinski
(ring-buffer-push! recent-pastes "9545") ; div0 ;; (ring-buffer-push! recent-pastes "9545") ; div0
(ring-buffer-push! recent-pastes "3516") ; circles (test require) ;; (ring-buffer-push! recent-pastes "3516") ; circles (test require)
(ring-buffer-push! recent-pastes "3289") ; Greek letters ;; (ring-buffer-push! recent-pastes "3289") ; Greek letters
(ring-buffer-push! recent-pastes "2531") ; lazy fib ;; (ring-buffer-push! recent-pastes "2531") ; lazy fib
(ring-buffer-push! recent-pastes "7747") ; set bang ;; (ring-buffer-push! recent-pastes "7747") ; set bang
(ring-buffer-push! recent-pastes "2417") ; scribble syntax ;; (ring-buffer-push! recent-pastes "2417") ; scribble syntax
(ring-buffer-push! recent-pastes "9425") ; big bang (test 1 line, 2 requires) ;; (ring-buffer-push! recent-pastes "9425") ; big bang (test 1 line, 2 requires)
(ring-buffer-push! recent-pastes "5291") ; typed/racket ;; (ring-buffer-push! recent-pastes "9265") ; typed/racket
(ring-buffer-push! recent-pastes "8937") ; datalog ;; ;(ring-buffer-push! recent-pastes "7239") ; typed/racket
;; (ring-buffer-push! recent-pastes "8937") ; datalog
(define hashlang-pat #px"^\\#lang ([\\w/]+)\\s*(.*)") (define sample-pastes
'("4557" ; Sierpinski
"9545" ; div1
"3516" ; circles (test require)
"3289" ; Greek letters
"2531" ; lazy fib
"7747" ; set bang (test multi-expr, no #lang)
"2417" ; scribble syntax
"9425" ; big bang (test 2 requires on 1 line)
"9265" ; typed/racket
; "7239" ; another typed/racket
"8937" ; datalog
"2979" ; test limits, and forms in racket but not racket/base
"7169" ; racket/gui
"5352" ; test 2 specs in 1 require
"1216" ; another typed/racket
"6813" ; ffi
))
(define NUM-RECENT-PASTES 32)
(define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES))
(for ([p sample-pastes]) (ring-buffer-push! recent-pastes p))
(define hashlang-pat #px"^\\#lang ([\\w/-]+)\\s*(.*)")
(define weblang-pat #px"^web-server.*")
(define scribblelang-pat #px"^scribble/.*") (define scribblelang-pat #px"^scribble/.*")
(define htdplang-pat #px"^htdp/.*") (define htdplang-pat #px"^htdp/.*")
(define TRlang-pat #px"^typed/racket.*") (define TRlang-pat #px"^typed/racket.*")
@ -58,6 +81,7 @@
(define (scribble-lang? lang) (regexp-match scribblelang-pat lang)) (define (scribble-lang? lang) (regexp-match scribblelang-pat lang))
(define (htdp-lang? lang) (regexp-match htdplang-pat lang)) (define (htdp-lang? lang) (regexp-match htdplang-pat lang))
(define (TR-lang? lang) (regexp-match TRlang-pat lang)) (define (TR-lang? lang) (regexp-match TRlang-pat lang))
(define (web-lang? lang) (regexp-match weblang-pat lang))
(define (require-datum? e) (get-require-spec e)) (define (require-datum? e) (get-require-spec e))
(define (get-require-spec e) (regexp-match require-pat (to-string e))) (define (get-require-spec e) (regexp-match require-pat (to-string e)))
@ -70,6 +94,7 @@
(cond [(scribble-lang? lang) (list "racket" lang)] (cond [(scribble-lang? lang) (list "racket" lang)]
[(htdp-lang? lang) (list "racket")] [(htdp-lang? lang) (list "racket")]
[(TR-lang? lang) (list "racket")] [(TR-lang? lang) (list "racket")]
[(web-lang? lang) (list "web-server" "web-server/http")]
[else (list lang)])) [else (list lang)]))
; (printf "~v" lang-lst) ; (printf "~v" lang-lst)
(define reqs (define reqs
@ -90,22 +115,54 @@
#:exists 'replace) #:exists 'replace)
tmp-name) tmp-name)
(define (write-eval-scrbl-file code) (define (write-eval-scrbl-file code)
(define-values (lang code-no-lang) (hashlang-split code))
;; parse out #lang if it's there ;; parse out #lang if it's there
(define lang-match (regexp-match #px"^\\#lang ([\\w/]+)\\s*(.*)" code)) ; (define lang-match (regexp-match #px"^\\#lang ([\\w/]+)\\s*(.*)" code))
(define-values (code-no-lang lang) ;; (define-values (code-no-lang lang)
(match lang-match [(list _ lang rst) (values rst lang)] ;; (match lang-match [(list _ lang rst) (values rst lang)]
[_ (values code "racket")])) ;; [_ (values code "racket")]))
; (printf "~v" lang) (flush-output)
(define tmp-name (mk-rand-str)) (define tmp-name (mk-rand-str))
(define tmp-scrbl-file (build-path tmp-dir (++ tmp-name ".scrbl"))) (define tmp-scrbl-file (build-path tmp-dir (++ tmp-name ".scrbl")))
(with-output-to-file tmp-scrbl-file (with-output-to-file tmp-scrbl-file
(lambda () (lambda ()
(printf (++ "#lang scribble/manual\n" ;; (printf (++ "#lang scribble/manual\n"
"@(require scribble/eval)\n" ;; "@(require scribble/eval)\n"
"@(define the-eval (make-base-eval" ;; "@(define the-eval (make-base-eval"
(if (string=? "racket" lang) "" (++ " #:lang '" lang)) ;; (if (string=? "racket" lang) "" (++ " #:lang '" lang))
"))\n" ;; "))\n"
"@interaction[#:eval the-eval\n~a]") ;; "@interaction[#:eval the-eval\n~a]")
code-no-lang)) (printf
(++ "#lang scribble/manual\n"
"@(require scribble/eval racket/sandbox)\n"
"@(define-namespace-anchor anchor)\n"
"@(define the-eval\n"
" (call-with-trusted-sandbox-configuration\n"
" (lambda ()\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 '([exists \"/\"])]\n"
" [sandbox-eval-limits '(8 64)])\n"
" (let ([e (make-evaluator '" lang ")])\n"
;; " (let ([ns (namespace-anchor->namespace anchor)])\n"
;; " (call-in-sandbox-context e\n"
;; " (lambda () (namespace-attach-module ns "
;; "'file/convertible)))\n"
" (call-in-sandbox-context e\n"
" (lambda ()\n"
;; " (unless (namespace-variable-value "
;; "'pretty-print-handler #t (lambda () #f))\n"
;; " (namespace-attach-module ns 'racket/pretty))\n"
" (current-print (dynamic-require 'racket/pretty "
"'pretty-print-handler))))\n"
" e)))))\n"
"@interaction[#:eval the-eval\n~a]")
code-no-lang))
#:mode 'text #:mode 'text
#:exists 'replace) #:exists 'replace)
tmp-name) tmp-name)
@ -149,7 +206,23 @@
(head (head
(title "PasteRack: The Racket pastebin.") (title "PasteRack: The Racket pastebin.")
(script ((type "text/javascript")) ,google-analytics-script)) (script ((type "text/javascript")) ,google-analytics-script))
(body ((style "margin-top:10px")) (body ((style "margin-top:20px"))
(div ((style "margin-left:5px;position:relative;float:left;margin-right:-10em"))
(h4 "Total pastes: " ,(number->string (DBSIZE)))
(h4 "Sample pastes:")
(table ((style "margin-top:-15px"))
,@(for/list ([pnum sample-pastes])
(define name (bytes->string/utf-8 (HGET pnum 'name)))
`(tr (td ,(mk-link (mk-paste-url pnum) pnum))
(td ((style "width:1px"))) (td ,name))))
(h4 "Recent pastes:")
(table ((style "margin-top:-15px"))
,@(reverse
(for/list ([pnum recent-pastes] #:when pnum)
(define name (bytes->string/utf-8 (HGET pnum 'name)))
`(tr (td ,(mk-link (mk-paste-url pnum) pnum))
(td ((style "width:1px"))) (td ,name))))))
(div
(center (center
(img ((src ,racket-logo-url))) (img ((src ,racket-logo-url)))
(h1 ,(mk-link pastebin-url "PasteRack") ": The " (h1 ,(mk-link pastebin-url "PasteRack") ": The "
@ -158,23 +231,24 @@
(table (tr (table (tr
(td (input ((type "text") (name "name") (size "60")))) (td (input ((type "text") (name "name") (size "60"))))
(td "(paste title)"))) (td "(paste title)")))
(textarea ((rows "20") (cols "80") (name "paste"))) (textarea ((rows "32") (cols "80") (name "paste")))
(br) (br)
(table (tr (td ((style "width:10em"))) (table (tr (td ((style "width:10em")))
(td ((style "width:8em")) (td ((style "width:8em"))
(input ((type "submit") (value "Submit Paste")))) (input ((type "submit") (value "Submit Paste"))))
(td (input ((type "checkbox") (name "astext") (value "off"))) (td (input ((type "checkbox") (name "astext") (value "off")))
" Submit as text only")))) " Submit as text only"))))
(br) ; (br)
(h3 "Total pastes: " ,(number->string (DBSIZE))) ; (h3 "Recent pastes:")
(h3 "Recent pastes:") ;; (table ((style "margin-top:-15px"))
(table ((style "margin-top:-15px")) ;; ,@(reverse
,@(reverse ;; (for/list ([pnum recent-pastes] #:when pnum)
(for/list ([pnum recent-pastes] #:when pnum) ;; (define name (bytes->string/utf-8 (HGET pnum 'name)))
(define name (bytes->string/utf-8 (HGET pnum 'name))) ;; `(tr (td ((style "width:20px")))
`(tr (td ((style "width:20px"))) ;; (td ,(mk-link (mk-paste-url pnum) pnum))
(td ,(mk-link (mk-paste-url pnum) pnum)) ;; (td ((style "width:2px"))) (td ,name))))))
(td ((style "width:2px"))) (td ,name)))))))))) ))
(div ((style "width:10em;position:relative;float:right")))))))
(send/suspend/dispatch response-generator)) (send/suspend/dispatch response-generator))
(define (process-paste request) (define (process-paste request)