From e62a875c43b47ce093718bfda886e6d1227c7b73 Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Wed, 16 Oct 2013 23:35:32 +0000 Subject: [PATCH] validate reqs before requiring for-label; fixes #29 --- pasterack-parsing-utils.rkt | 23 +++++++-- pasterack.rkt | 97 ++++++++++++++++++++++--------------- 2 files changed, 78 insertions(+), 42 deletions(-) diff --git a/pasterack-parsing-utils.rkt b/pasterack-parsing-utils.rkt index 0ca6061..833abaf 100644 --- a/pasterack-parsing-utils.rkt +++ b/pasterack-parsing-utils.rkt @@ -45,10 +45,25 @@ (define check-pat #px"^\\(check-(.*)\\)$") (define (require-datum? e) (get-require-spec e)) -(define (provide-datum? e) (regexp-match provide-pat (to-string e))) +(define (provide-datum? e) (regexp-match provide-pat (to-string/s e))) (define (define-datum? e) (regexp-match define-pat (to-string e))) (define (check-datum? e) (regexp-match check-pat (to-string e))) -(define (get-require-spec e) (regexp-match require-pat (to-string e))) +(define (get-require-spec e) (regexp-match require-pat (to-string/s e))) + +;; for now, only accept certain forms +;; (ie reject strings) +(define (valid-req? r) + (or (symbol? r) + (and (pair? r) + (let ([form (car r)]) + (define (symeq? x) (eq? x form)) + (or + (and (ormap symeq? '(only-in except-in rename-in)) + (valid-req? (second r))) + (and (ormap symeq? '(prefix-in)) + (valid-req? (third r))) + (and (ormap symeq? '(combine-in)) + (andmap valid-req? (cdr r)))))))) (define (not-htdp-expr? e) (or (require-datum? e) (provide-datum? e) (check-datum? e) (define-datum? e))) @@ -68,8 +83,8 @@ ;; ie, an expression? (identifier? (stx-car expanded)) (stx-car expanded))) - (fprintf out "expanded: ~a\n" (syntax->datum expanded)) - (fprintf out "hd: ~a\n" hd) + ;; (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) diff --git a/pasterack.rkt b/pasterack.rkt index ee29433..1c1ecce 100644 --- a/pasterack.rkt +++ b/pasterack.rkt @@ -9,7 +9,7 @@ "pasterack-test-cases.rkt") ;; irc bot -(require racket-irc/irc/main) +(require irc) (require racket/async-channel) (provide/contract (start (request? . -> . response?))) @@ -18,13 +18,15 @@ (define-runtime-path here-dir ".") (define-runtime-path tmp-dir "tmp") -(define pastebin-url "http://www.pasterack.org/") +(define pastebin-url "http://162.243.38.241:8000/") (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/stchang/plt/racket/bin/scribble") + (define (mk-paste-url paste-num) (++ paste-url-base paste-num)) ;(define (mk-link url txt) `(a ((href ,url)) ,txt)) @@ -37,11 +39,11 @@ (define log-file (build-path here-dir "pasterack.log")) (define log-port (open-output-file log-file #:mode 'text #:exists 'append)) -;; irc bot +;irc bot (define-values (irc-connection ready) - (irc-connect "card.freenode.net" 6667 "pasterack" "pasterack" "pasterack.org")) + (irc-connect "card.freenode.net" 6667 "pasterackm" "pasterackm" "pasterack.org mirror")) (sync ready) -(define irc-channels '("#racket")) +(define irc-channels '("#racktest")) (for ([chan irc-channels]) (irc-join-channel irc-connection chan)) (define sample-pastes @@ -86,6 +88,13 @@ (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" @@ -99,15 +108,15 @@ ;; when required id is also in lang, favor require (cond [(htdp-lang? lang) - (++ (string-join reqs) " " + (++ valid-reqs " " "(subtract-in " (car lang-lst) - " (combine-in " (string-join reqs) "))")] + " (combine-in " valid-reqs "))")] ;; (car lang-lst) " (subtract-in (combine-in " ;; (string-join reqs) ") " (car lang-lst) ")")] ; [else (string-join (append lang-lst reqs))]) - [else (++ (string-join reqs) " " + [else (++ valid-reqs " " "(subtract-in (combine-in " (string-join lang-lst) ")" - " (combine-in " (string-join reqs) "))")]) + " (combine-in " valid-reqs "))")]) "))\n" "@codeblock|{\n~a}|") code)) @@ -164,7 +173,7 @@ ;; non htdp lang -------------------------------------------------- [else (define datums (string->datums code-no-lang)) - (for ([d datums]) (fprintf out "~a\n" d)) +; (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))) @@ -213,7 +222,7 @@ (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 (++ "/home/stchang/pltpkg/racket/bin/scribble --html " + (begin0 (system (++ scrbl-exe " --html " "+m --redirect-main " racket-docs-url " " "--dest " (path->string new-tmpdir) " " (path->string scrbl-file))) @@ -223,7 +232,7 @@ (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 (++ "/home/stchang/pltpkg/racket/bin/scribble --html " + (and (system (++ scrbl-exe " --html " "--dest " (path->string new-tmpdir) " " (path->string scrbl-file))) (with-input-from-file html-file port->bytes))) @@ -272,6 +281,23 @@ "fjs.parentNode.insertBefore(js,fjs);}}" "(document, 'script', 'twitter-wjs');")) +(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) @@ -300,14 +326,17 @@ "background-size:cover")]) ;; head ---------------------------------------------------------------- (head - (title "PasteRack: A Racket-evaluating pastebin") + (title "PasteRack (MIRROR): A Racket-evaluating pastebin") (script ((type "text/javascript")) ,google-analytics-script) - (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"]))) + ,droidsansmono-css/x ,ptsans-css/x + ;; (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")) + (h1 "MIRROR") ;; left -------------------------------------------------------------- (div ((style ,(~~ "position:absolute;left:1em;top:2em" "width:12em" @@ -449,16 +478,6 @@ (xml->xexpr (document-element (with-input-from-bytes html-bytes read-xml)))))))) -(define droidsansmono-css/x - '(link ([type "text/css"] [rel "stylesheet"] - [href "http://fonts.googleapis.com/css?family=Droid+Sans+Mono"]))) -(define scrbl-css/x - '(link ([type "text/css"] [rel "stylesheet"] - [href "http://pasterack.org/scribble.css"]))) -(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 @@ -558,7 +577,7 @@ (delete-file curr-file-path)) `(tr () (td () (p () (img ((alt "image") ,height - (src ,(++ "http://pasterack.org/" new-file)) ,width)))))] + (src ,(++ pastebin-url new-file)) ,width)))))] ;; nested table [`(tr () (td () (table ,attrs . ,rows))) `(tr () (td () (table ([style ,(~~ "font-size:95%" @@ -584,16 +603,18 @@ (meta ((content "text-html; charset=utf-8") (http-equiv "content-type"))) (title ,(++ "Paste # " pastenum ": " name)) - (link ((href "/scribble.css") (rel "stylesheet") - (title "default") (type "text/css"))) - (link ((href "/racket.css") (rel "stylesheet") - (title "default") (type "text/css"))) - (link ((href "/scribble-style.css") (rel "stylesheet") - (title "default") (type "text/css"))) - (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"])) + ,scrbl-css/x ,rkt-css/x ,scrbl-style-css/x + ,droidsansmono-css/x ,ptsans-css/x + ;; (link ((href "/scribble.css") (rel "stylesheet") + ;; (title "default") (type "text/css"))) + ;; (link ((href "/racket.css") (rel "stylesheet") + ;; (title "default") (type "text/css"))) + ;; (link ((href "/scribble-style.css") (rel "stylesheet") + ;; (title "default") (type "text/css"))) + ;; (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"])) (script ((src "/scribble-common.js") (type "text/javascript"))) (script ,twitter-script)) (body ([style ,(~~ "font-family:'PT Sans',sans-serif"