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

fix eval; add recent pastes

Browse Source 
- render codeblock and eval in separate passes
- use scribble interactions instead of interaction-eval-show
This commit is contained in:
Stephen Chang 2013-10-01 17:10:47 +00:00
parent 0510928e53
commit b57a934531
1 changed files with 157 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

197
pasterack.rkt
View File

@ -4,18 +4,21 @@
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)
(provide/contract (start (request? . -> . response?))) (provide/contract (start (request? . -> . response?)))
(define-runtime-path tmp-html-file "test.html") ;; (define-runtime-path tmp-html-file "test.html")
(define-runtime-path tmp-scrbl-file "test.scrbl") ;; (define-runtime-path tmp-scrbl-file "test.scrbl")
(define-runtime-path htdocs-dir "htdocs") (define-runtime-path htdocs-dir "htdocs")
(define-runtime-path here ".") (define-runtime-path here ".")
(define-runtime-path tmp-dir "tmp")
(define ++ string-append)
(define +++ string-append) (define +++ string-append)
(define pastebin-url "http://www.pasterack.org/") (define pastebin-url "http://www.pasterack.org/")
(define paste-url-base (+++ pastebin-url "pastes/")) (define paste-url-base (++ pastebin-url "pastes/"))
(define racket-docs-url "http://docs.racket-lang.org/") (define racket-docs-url "http://docs.racket-lang.org/")
(define racket-lang-url "http://racket-lang.org") (define racket-lang-url "http://racket-lang.org")
(define racket-logo-url "http://racket-lang.org/logo.png") (define racket-logo-url "http://racket-lang.org/logo.png")
@ -23,26 +26,74 @@
(define (mk-link url txt) (define (mk-link url txt)
`(a ((href ,url) (onclick ,(+++ "top.location.href=\"" url "\""))) ,txt)) `(a ((href ,url) (onclick ,(+++ "top.location.href=\"" url "\""))) ,txt))
(define (write-scribble-file code) (define NUM-RECENT-PASTES 5)
(define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES))
;; initialize buffer with some pastes
(ring-buffer-push! recent-pastes "4363")
(ring-buffer-push! recent-pastes "4548")
(ring-buffer-push! recent-pastes "8249")
(ring-buffer-push! recent-pastes "9921")
(ring-buffer-push! recent-pastes "7145")
;; returns output file name (as path), or #f on fail
(define (write-codeblock-scrbl-file code)
(define tmp-name (mk-rand-str))
(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 (for-label racket))\n" "@(require (for-label racket))\n"
"@(require scribble/eval)\n" "@codeblock{\n~a}")
"@(define the-eval (make-base-eval))\n"
; "@codeblock[#:line-numbers 0]{\n~a}")
"@codeblock{\n~a}\n")
; "@interaction-eval-show[#:eval the-eval ~a]")
code)) code))
#:mode 'text #:mode 'text
#:exists 'replace)) #:exists 'replace)
(define (compile-scribble-file code) tmp-name)
(define (write-eval-scrbl-file code)
(define lang-match (regexp-match #px"^\\#lang ([\\w/]+)\\s*(.*)" code))
(define code-no-lang (match lang-match [(list _ _ rst) rst] [_ code]))
(define lang (match lang-match [(list _ lang _) lang] [_ "racket"]))
(define tmp-name (mk-rand-str))
(define tmp-scrbl-file (build-path tmp-dir (++ tmp-name ".scrbl")))
(with-output-to-file tmp-scrbl-file
(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]")
code-no-lang))
#:mode 'text
#:exists 'replace)
tmp-name)
#;(define (compile-scribble-file code)
(with-handlers ([exn:fail? (lambda (x) (displayln (exn-message x)) #f)])
(write-scribble-file code) (write-scribble-file code)
(system (+++ "/home/stchang/pltpkg/racket/bin/scribble --html +m " (system (+++ "/home/stchang/pltpkg/racket/bin/scribble --html +m "
; "++xref-in setup/xref load-collections-xref " ; "++xref-in setup/xref load-collections-xref "
"--redirect-main " racket-docs-url " " "--redirect-main " racket-docs-url " "
"--dest " (path->string here) " " "--dest " (path->string here) " "
(path->string tmp-scrbl-file)))) (path->string tmp-scrbl-file)))))
(define (compile-scrbl-file/get-html name)
(and
(system (++ "/home/stchang/pltpkg/racket/bin/scribble --html +m "
"--redirect-main " racket-docs-url " "
"--dest " (path->string tmp-dir) " "
(path->string (build-path tmp-dir (++ name ".scrbl")))))
(with-input-from-file (build-path tmp-dir (++ name ".html")) port->bytes)))
(define (compile-eval-scrbl-file/get-html name)
(and
(system (++ "/home/stchang/pltpkg/racket/bin/scribble --html "
"--dest " (path->string tmp-dir) " "
(path->string (build-path tmp-dir (++ name ".scrbl")))))
(with-input-from-file (build-path tmp-dir (++ name ".html")) port->bytes)))
(define (generate-paste-html code)
(compile-scrbl-file/get-html (write-codeblock-scrbl-file code)))
(define (generate-eval-html code)
(compile-eval-scrbl-file/get-html (write-eval-scrbl-file code)))
(define (mk-paste-url paste-num) (++ paste-url-base paste-num))
(define google-analytics-script (define google-analytics-script
(+++ "var _gaq = _gaq || [];\n" (+++ "var _gaq = _gaq || [];\n"
@ -72,7 +123,16 @@
(form ((action ,(embed/url process-paste)) (method "post")) (form ((action ,(embed/url process-paste)) (method "post"))
(textarea ((rows "20") (cols "79") (name "paste"))) (textarea ((rows "20") (cols "79") (name "paste")))
(br) (br)
(input ((type "submit") (value "Submit Paste"))))))))) (input ((type "submit") (value "Submit Paste"))))
(br) (br) (br)
(h3 "Recent pastes:")
,@(apply append
(reverse
(for/list ([n NUM-RECENT-PASTES])
(define paste-num (ring-buffer-ref recent-pastes n))
(if paste-num
(list (mk-link (mk-paste-url paste-num) paste-num) '(br))
null)))))))))
(send/suspend/dispatch response-generator)) (send/suspend/dispatch response-generator))
(define (mk-rand-str) (define (mk-rand-str)
@ -86,48 +146,54 @@
(define bs (request-bindings request)) (define bs (request-bindings request))
(cond (cond
[(exists-binding? 'paste bs) [(exists-binding? 'paste bs)
(define pastenum (fresh-str)) (define paste-num (fresh-str))
(define paste-url (+++ paste-url-base pastenum)) (define pasted-code (extract-binding/single 'paste bs))
(define code (extract-binding/single 'paste bs)) (define html-res (generate-paste-html pasted-code))
(define html-str (define paste-html-str (or html-res pasted-code))
(if (compile-scribble-file code) (define eval-html-str (and html-res (generate-eval-html pasted-code)))
(with-input-from-file tmp-html-file port->bytes) ;; (if (compile-scribble-file pasted-code)
code)) ;; (with-input-from-file tmp-html-file port->bytes)
;; (car (filter ;; code))
;; (lambda (d) (equal? "main" (se-path* '(div #:class) d))) ;; ;; (car (filter
;; (se-path*/list '(div) ;; ;; (lambda (d) (equal? "main" (se-path* '(div #:class) d)))
;; (xml->xexpr (document-element ;; ;; (se-path*/list '(div)
;; (with-input-from-file tmp-html-file read-xml))))))) ;; ;; (xml->xexpr (document-element
(SET pastenum html-str) ;; ;; (with-input-from-file tmp-html-file read-xml)))))))
(define paste-url (mk-paste-url paste-num))
(ring-buffer-push! recent-pastes paste-num)
(SET/list paste-num (list paste-html-str (or eval-html-str "")))
(response/xexpr (response/xexpr
`(html () `(html ()
(head () (head ()
(script () ,(+++ "top.location.href=\"" paste-url "\""))) (script () ,(++ "top.location.href=\"" paste-url "\"")))
(body ())))] (body ())))]
[else [else
(response/xexpr (response/xexpr
`(html () `(html ()
(head ()) (head ())
(body () "ERROR" ,(mk-link pastebin-url "Go Back"))))])) (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 (serve-paste request pastenum)
(define html-str (GET pastenum)) (define retrieved-paste (GET/list pastenum))
(cond (cond
[(not html-str) [(null? retrieved-paste)
(response/xexpr (response/xexpr
`(html() (head ()) `(html() (head ())
(body () (body ()
,(format "Paste # ~a doesn't exist." pastenum) (br) ,(format "Paste # ~a doesn't exist." pastenum) (br)
,(mk-link pastebin-url "Go Back"))))] ,(mk-link pastebin-url "Go Back"))))]
[else [else
; (compile-scribble-file code) (match-define (list code-html eval-html) (GET/list pastenum))
(define main-div (define code-main-div (get-main-div code-html))
(with-handlers ([exn:fail? (lambda (x) (bytes->string/utf-8 html-str))]) (define eval-main-div (get-main-div eval-html))
(car (filter
(lambda (d) (equal? "main" (se-path* '(div #:class) d)))
(se-path*/list '(div)
(xml->xexpr (document-element
(with-input-from-bytes html-str read-xml))))))))
(define paste-url (string-append paste-url-base pastenum)) (define paste-url (string-append paste-url-base pastenum))
(response/xexpr (response/xexpr
`(html () `(html ()
@ -147,10 +213,51 @@
,(mk-link pastebin-url "PasteRack") ,(mk-link pastebin-url "PasteRack")
" Paste # " (a ((href ,paste-url)) ,pastenum) " Paste # " (a ((href ,paste-url)) ,pastenum)
(div ((class "maincolumn")) (div ((class "maincolumn"))
,(match main-div ,(match code-main-div
[`(div ((class "main")) ,ver ,body) [`(div ((class "main")) ,ver ,body)
`(div ((class "main")) ,body)] `(div ((class "main"))
[_ `(div ,main-div)])))))])) ,body
(p "=>")
,(match eval-main-div
[`(div ((class "main")) ,ver
(blockquote ,attr1 (table ,attr2 . ,results)))
`(blockquote ,attr1 (table ,attr2 .
,(filter
identity
(map
(lambda (x)
;; (printf "~v\n" x)
;; (flush-output)
(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]
;; fix filename in image link
[`(tr () (td () (p () (img
((alt "image") ,height
(src ,filename) ,width)))))
`(tr () (td () (p () (img
((alt "image") ,height
(src ,(++ "/" filename)) ,width)))))]
[x x]))
results))))]
[_ `(div ,eval-main-div)]))]
;; ;; filter void outputs
;; ,(filter
;; (lambda (x)
;; (match x
;; ['(p () (span ((class "RktRes")) "#" "<" "void" ">")) #f]
;; [_ #t]))
;; results))]
[_ `(div ,code-main-div)])))))]))
;; [`(div ((class "main")) ,ver (p () ,code ,res)) ;; [`(div ((class "main")) ,ver (p () ,code ,res))
;; `(div ((class "main")) (p () ,code (div "=>") ,res))])))))])) ;; `(div ((class "main")) (p () ,code (div "=>") ,res))])))))]))
;; ,(cons (car main-div) (cons (cadr main-div) (cdddr main-div)))))))])) ;; ,(cons (car main-div) (cons (cadr main-div) (cdddr main-div)))))))]))
@ -174,6 +281,6 @@
#:quit? #f #:quit? #f
#:listen-ip #f #:listen-ip #f
#:port 8000 #:port 8000
#:extra-files-paths (list htdocs-dir) #:extra-files-paths (list tmp-dir htdocs-dir)
#:servlet-path "/" #:servlet-path "/"
#:servlet-regexp #rx".*") #:servlet-regexp #rx".*")