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

code cleanup

Browse Source
This commit is contained in:
Stephen Chang 2013-10-03 03:24:44 -04:00
parent e8694e1602
commit 33d48af9cf
1 changed files with 7 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
pasterack.rkt
View File

@ -1,11 +1,9 @@
#lang racket #lang racket
(require web-server/servlet (require web-server/servlet web-server/dispatch)
web-server/dispatch)
(require xml xml/path) (require xml xml/path)
(require racket/system racket/runtime-path) (require racket/system racket/runtime-path)
(require redis (require redis data/ring-buffer)
data/ring-buffer)
(require "pasterack-utils.rkt") (require "pasterack-utils.rkt")
(provide/contract (start (request? . -> . response?))) (provide/contract (start (request? . -> . response?)))
@ -28,19 +26,6 @@
(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)))
;; initialize buffer with some pastes
;; (ring-buffer-push! recent-pastes "4557") ; Sierpinski
;; (ring-buffer-push! recent-pastes "9545") ; div0
;; (ring-buffer-push! recent-pastes "3516") ; circles (test require)
;; (ring-buffer-push! recent-pastes "3289") ; Greek letters
;; (ring-buffer-push! recent-pastes "2531") ; lazy fib
;; (ring-buffer-push! recent-pastes "7747") ; set bang
;; (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 "9265") ; typed/racket
;; ;(ring-buffer-push! recent-pastes "7239") ; typed/racket
;; (ring-buffer-push! recent-pastes "8937") ; datalog
(define sample-pastes (define sample-pastes
'("4557" ; Sierpinski '("4557" ; Sierpinski
"9545" ; div1 "9545" ; div1
@ -51,19 +36,20 @@
"2417" ; scribble syntax "2417" ; scribble syntax
"9425" ; big bang (test 2 requires on 1 line) "9425" ; big bang (test 2 requires on 1 line)
"9265" ; typed/racket "9265" ; typed/racket
; "7239" ; another typed/racket
"8937" ; datalog "8937" ; datalog
"2979" ; test limits, and forms in racket but not racket/base "2979" ; test limits, and forms in racket but not racket/base
"7169" ; racket/gui "7169" ; racket/gui
"5352" ; test 2 specs in 1 require "5352" ; test 2 specs in 1 require
"1216" ; another typed/racket "1216" ; another typed/racket
"6813" ; ffi "6813" ; ffi
"5752" ; bs ipsum (as text)
)) ))
(define NUM-RECENT-PASTES 32) (define NUM-RECENT-PASTES 32)
(define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES)) (define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES))
(for ([p sample-pastes]) (ring-buffer-push! recent-pastes p)) (for ([p sample-pastes]) (ring-buffer-push! recent-pastes p))
;; lang regexp patterns
(define hashlang-pat #px"^\\#lang ([\\w/-]+)\\s*(.*)") (define hashlang-pat #px"^\\#lang ([\\w/-]+)\\s*(.*)")
(define weblang-pat #px"^web-server.*") (define weblang-pat #px"^web-server.*")
(define scribblelang-pat #px"^scribble/.*") (define scribblelang-pat #px"^scribble/.*")
@ -85,7 +71,7 @@
(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)))
;; returns output file name (as path), or #f on fail ;; returns generated pastenum
(define (write-codeblock-scrbl-file code) (define (write-codeblock-scrbl-file code)
(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")))
@ -96,42 +82,27 @@
[(TR-lang? lang) (list "racket")] [(TR-lang? lang) (list "racket")]
[(web-lang? lang) (list "web-server" "web-server/http")] [(web-lang? lang) (list "web-server" "web-server/http")]
[else (list lang)])) [else (list lang)]))
; (printf "~v" lang-lst)
(define reqs (define reqs
(with-handlers ([exn:fail? (const null)]) ;; read fail = non-sexp syntax (with-handlers ([exn:fail? (const null)]) ;; read fail = non-sexp syntax
(with-input-from-string code-no-lang (with-input-from-string code-no-lang
(lambda () (for/list ([e (in-port)] #:when (require-datum? e)) (lambda () (for/list ([e (in-port)] #:when (require-datum? e))
(second (get-require-spec e))))))) (second (get-require-spec e)))))))
; (printf "~v" reqs) (flush-output)
(with-output-to-file tmp-scrbl-file (with-output-to-file tmp-scrbl-file
(lambda () (printf (lambda () (printf
(++ "#lang scribble/manual\n" (++ "#lang scribble/manual\n"
"@(require (for-label " (string-join (append lang-lst reqs)) "))\n" "@(require (for-label " (string-join (append lang-lst reqs)) "))\n"
; lang " " (apply ++ reqs)
; "@(require (for-label racket" "))\n"
"@codeblock|{\n~a}|") "@codeblock|{\n~a}|")
code)) code))
#:mode 'text #:mode 'text
#:exists 'replace) #:exists 'replace)
tmp-name) tmp-name)
(define (write-eval-scrbl-file code) (define (write-eval-scrbl-file code)
; parse out #lang if it's there, otherwise use racket
(define-values (lang code-no-lang) (hashlang-split code)) (define-values (lang code-no-lang) (hashlang-split code))
;; parse out #lang if it's there
; (define lang-match (regexp-match #px"^\\#lang ([\\w/]+)\\s*(.*)" code))
;; (define-values (code-no-lang lang)
;; (match lang-match [(list _ lang rst) (values rst lang)]
;; [_ (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"
;; "@(require scribble/eval)\n"
;; "@(define the-eval (make-base-eval"
;; (if (string=? "racket" lang) "" (++ " #:lang '" lang))
;; "))\n"
;; "@interaction[#:eval the-eval\n~a]")
(printf (printf
(++ "#lang scribble/manual\n" (++ "#lang scribble/manual\n"
"@(require scribble/eval racket/sandbox)\n" "@(require scribble/eval racket/sandbox)\n"
@ -149,15 +120,8 @@
" [sandbox-path-permissions '([exists \"/\"])]\n" " [sandbox-path-permissions '([exists \"/\"])]\n"
" [sandbox-eval-limits '(8 64)])\n" " [sandbox-eval-limits '(8 64)])\n"
" (let ([e (make-evaluator '" lang ")])\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" " (call-in-sandbox-context e\n"
" (lambda ()\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 " " (current-print (dynamic-require 'racket/pretty "
"'pretty-print-handler))))\n" "'pretty-print-handler))))\n"
" e)))))\n" " e)))))\n"
@ -237,17 +201,7 @@
(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)
; (h3 "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 ((style "width:20px")))
;; (td ,(mk-link (mk-paste-url pnum) pnum))
;; (td ((style "width:2px"))) (td ,name))))))
))
(div ((style "width:10em;position:relative;float:right"))))))) (div ((style "width:10em;position:relative;float:right")))))))
(send/suspend/dispatch response-generator)) (send/suspend/dispatch response-generator))
@ -342,8 +296,6 @@
identity identity
(map (map
(lambda (x) (lambda (x)
;; (printf "~v\n" x)
;; (flush-output)
(match x (match x
;; single-line evaled expr (with ">" prompt), skip ;; single-line evaled expr (with ">" prompt), skip
[`(tr () (td () (span ((class "stt")) ">" " ") . ,rst)) [`(tr () (td () (span ((class "stt")) ">" " ") . ,rst))