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

add partial expansion first pass, closes #25

Browse Source 
- add test cases file
This commit is contained in:
Stephen Chang 2013-10-10 17:57:30 -04:00
parent 929b15ddd0
commit 29ba45bb8d
4 changed files with 135 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
pasterack-parsing-utils.rkt
View File

@ -1,4 +1,5 @@
#lang racket
(require syntax/stx)
(require "pasterack-utils.rkt")
;; parsing utility functions used by pasterack.org
@ -57,3 +58,32 @@
(define (string->datums s)
(with-handlers ([exn:fail? (lambda () null)])
(with-input-from-string s (lambda () (for/list ([e (in-port)]) e)))))
;; stx predicates
(define (not-expr? d [out (current-output-port)])
(with-handlers ([exn:fail:syntax? (lambda (e) (displayln (exn-message e)) #t)])
(define expanded (expand-to-top-form d))
(define hd (and (stx-pair? expanded)
;; not identifier always means %#app, %#datum, or %#top (?)
;; ie, an expression?
(identifier? (stx-car expanded))
(stx-car expanded)))
(fprintf out "expanded: ~a\n" (syntax->datum expanded))
(fprintf out "hd: ~a\n" hd)
(and hd
;; check for begin
(or (and (free-identifier=? hd #'begin)
(for/and ([s (syntax->list (stx-cdr (expand d)))])
(not-expr? s out)))
(and
;; (when (or (free-identifier=? hd #'define-syntaxes)
;; (free-identifier=? hd #'begin-for-syntax)
;; (free-identifier=? hd #'#%require))
;; (eval d))
(for/or ([form
(syntax->list
;; ok to do define-values from interactions prompt
;; (but set! must be classified same as define-values)
#'(module module* begin-for-syntax
#%provide #%require define-syntaxes))])
(free-identifier=? hd form)))))))

32
pasterack-test-cases.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket/base
;; test cases for pasterack.org
(provide (all-defined-out))
(define test-cases
'(
;; path permissions
"7449" ; delete file
"4749" ; list root
"8953" ; Sierpinski
"5563" ; Greek letters
"4837" ; lazy fib
"1989" ; set bang (test multi-expr, no #lang)
"3259" ; scribble syntax
"5238" ; big bang (test 2 requires on 1 line)
"3883" ; echo serv, test limits, and forms in racket but not racket/base
"7658" ; typed/racket -- also example of begin in top-context
"9269" ; type error
"2277" ; checkerboard (slideshow/pict)
"4786" ; #lang htdp/bsl + 2htdp/image
"8314" ; check-expect
"9979" ; check-expect pass
"5873" ; plot -- also example of begin that should be expression
"7489" ; bad syntax
"3379" ; macro-generated set!
"4734" ; quibble (module+)
"5114" ; out of order macros
"8757" ; out of order defines
"5795" ; #lang blank
"4662" ; blank
;; BROKEN: submodule evaluation
))

7
pasterack-utils.rkt
View File

@ -2,6 +2,7 @@
(require racket/date racket/match)
(provide (all-defined-out))
(define o compose)
(define ++ string-append)
(define (to-string d) (format "~a" d))
(define (to-string/v d) (format "~v" d))
@ -17,3 +18,9 @@
#px"(\\d\\d\\d\\d-\\d\\d-\\d\\d)[MTWFS](\\d\\d:\\d\\d:\\d\\d)"
(date->string (current-date) #t)))
(++ date " " time)))
;; url utils
(define (mk-link url txt) `(a ((href ,url)) ,txt))
;; stx utils
(define (stx->string stx) (to-string/s (syntax->datum stx)))

116
pasterack.rkt
View File

@ -5,7 +5,8 @@
(require xml xml/path)
(require racket/system racket/runtime-path)
(require redis data/ring-buffer)
(require "pasterack-utils.rkt" "pasterack-parsing-utils.rkt")
(require "pasterack-utils.rkt" "pasterack-parsing-utils.rkt"
"pasterack-test-cases.rkt")
;; irc bot
(require racket-irc/irc/main)
@ -26,7 +27,7 @@
(define (mk-paste-url paste-num) (++ paste-url-base paste-num))
(define (mk-link url txt) `(a ((href ,url)) ,txt))
;(define (mk-link url txt) `(a ((href ,url)) ,txt))
(define (fresh-str)
(with-redis-connection
@ -37,25 +38,23 @@
(define log-port (open-output-file log-file #:mode 'text #:exists 'append))
;; irc bot
(define-values (connection ready)
(define-values (irc-connection ready)
(irc-connect "card.freenode.net" 6667 "pasterack" "pasterack" "pasterack.org"))
(sync ready)
(define irc-channels '("#racktest"))
(for ([chan irc-channels]) (irc-join-channel connection chan))
(define irc-channels '("#racket"))
(for ([chan irc-channels]) (irc-join-channel irc-connection chan))
(define sample-pastes
'("8953" ; Sierpinski
"5563" ; Greek letters
"4837" ; lazy fib
"1989" ; set bang (test multi-expr, no #lang)
"3259" ; scribble syntax
"5238" ; big bang (test 2 requires on 1 line)
"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
"9269" ; type error
"2277" ; checkerboard
"5873")) ; plot
; "7489")) ; bad syntax
(define sample-pastes-htmls
(let ([ns (with-redis-connection
(do-MULTI (for ([p sample-pastes]) (send-cmd 'HGET p 'name))))])
@ -66,7 +65,7 @@
(define NUM-RECENT-PASTES 16)
(define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES))
(for ([p sample-pastes]) (ring-buffer-push! recent-pastes p))
(for ([p test-cases]) (ring-buffer-push! recent-pastes p))
(define TR-bad-ids
(++ "#%module-begin with-handlers lambda λ #%top-interaction for for* "
@ -137,8 +136,9 @@
"(lambda () (namespace-anchor->namespace anchor)) "
"'(racket/pretty file/convertible))]\n"
" [sandbox-path-permissions "
"'([read \"/home/stchang/racket/pasterack/tmp/\"])]\n"
; "(list (list read ,tmp-dir))]\n"
"'([read \"/home/stchang/racket/pasterack/tmp/\"]\n"
;; images seem to need access to the prefs file
"[read \"/home/stchang/.racket/\"])]\n"
" [sandbox-eval-limits '(20 128)])\n"
" (let ([e (make-module-evaluator "
"'(module m " lang-name
@ -154,29 +154,18 @@
"@interaction[#:eval the-eval\n"
(string-join (map to-string/s code-exprs))
" (test)]"))]
;; no htdp lang --------------------------------------------------
;; non htdp lang --------------------------------------------------
[else
;; ; (define module-code (++ "(module m " lang " " code-no-lang ")"))
;; (define datums (string->datums code-no-lang))
;; ; (define module-datum (with-input-from-string module-code read-syntax))
;; ;; (define stxs
;; ;; (syntax-case
;; ;; (parameterize ([current-namespace (make-base-namespace)])
;; ;; (expand module-datum)) ()
;; ;; [(_ mname modpath (mbegin conf e ...)) (syntax->list #'(e ...))]))
;; ; (fprintf out "~a\n" stxs)
;; (define-values (mod-datums expr-datums)
;; (partition (lambda (d) (not-expr-stx? d lang)) datums))
;; ;; (define-values (mod-stxs expr-stxs)
;; ;; (partition
;; ;; (lambda (s+d) (not-expr-stx? (car s+d)))
;; ;; (map cons stxs datums)))
;; ;; (define mod-datums (map cdr mod-stxs))
;; ;; (define expr-datums (map cdr expr-stxs))
;; ; (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
(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"
@ -189,27 +178,25 @@
"(lambda () (namespace-anchor->namespace anchor)) "
"'(racket/pretty file/convertible))]\n"
" [sandbox-path-permissions "
; "'([read \"/\"])]\n"
"'([read \"/home/stchang/racket/pasterack/tmp/\"]"
"[read \"/home/stchang/.racket/\"])]\n"
" [sandbox-eval-limits '(20 128)])\n"
" (let ([e (make-evaluator '" lang ")])\n"
; " (let ([e (make-evaluator '(begin" "))])\n"
;; " (let ([e (make-module-evaluator "
;; "'(module m " lang "\n"
;; (string-join (map to-string/s mod-datums))
;; "))])\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))
;; "]")
;; )]))
;; "@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))
@ -430,7 +417,7 @@
(when (exists-binding? 'irc bs)
(define nick (extract-binding/single 'nick bs))
(for ([c irc-channels])
(irc-send-message connection c
(irc-send-message irc-connection c
(++ (if (string=? "" nick) "" (++ nick " pasted: "))
(if (string=? "" paste-name) "" (++ paste-name ", "))
paste-url))))
@ -464,7 +451,7 @@
(define rkt-css/x
'(link ([type "text/css"] [rel "stylesheet"]
[href "http://pasterack.org/racket.css"])))
(define (serve-paste request pastenum)
(define retrieved-paste-hash
(with-redis-connection
@ -635,10 +622,39 @@
,(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))))))
(define-values (do-dispatch mk-url)
(dispatch-rules
[("") serve-home]
[("pastes" (string-arg)) serve-paste]
[("tests") serve-tests]
#;[else serve-home]))