initial file

pasterack.rkt

@@ -0,0 +1,140 @@
+#lang racket
+
+(require web-server/servlet
+         web-server/dispatch)
+(require xml xml/path)
+(require racket/system racket/runtime-path)
+(require redis)
+(provide/contract (start (request? . -> . response?)))
+
+(define-runtime-path tmp-html-file "test.html")
+(define-runtime-path tmp-scrbl-file "test.scrbl")
+(define-runtime-path htdocs-dir "htdocs")
+(define-runtime-path here ".")
+
+(define +++ string-append)
+
+(define pastebin-url "http://www.pasterack.org/")
+(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 (mk-link url txt)
+  `(a ((href ,url) (onclick ,(+++ "top.location.href=\"" url "\""))) ,txt))
+
+(define (write-scribble-file code)
+  (with-output-to-file tmp-scrbl-file
+    (lambda ()
+      (printf (+++ "#lang scribble/manual\n"
+                   "@(require (for-label racket))\n"
+;                   "@codeblock[#:line-numbers 0]{\n~a}")
+                   "@codeblock{\n~a}")
+;                   "@racketblock[\n~a]")
+              code))
+    #:mode 'text
+    #:exists 'replace))
+(define (compile-scribble-file code)
+  (write-scribble-file code)
+  (system (+++ "/home/stchang/pltpkg/racket/bin/scribble --html +m "
+;               "++xref-in setup/xref load-collections-xref "
+               "--redirect-main " racket-docs-url " "
+               "--dest " (path->string here) " "
+               (path->string tmp-scrbl-file))))
+
+
+(define (serve-home request)
+  (define (response-generator embed/url)
+    (response/xexpr
+     `(html
+       (head (title "PasteRack: The Racket pastebin."))
+       (body
+        (center
+         (img ((src ,racket-logo-url)))
+         (h1 "PasteRack: The "
+             ,(mk-link racket-lang-url "Racket") " pastebin.")
+         (form ((action ,(embed/url process-paste)) (method "post"))
+               (textarea ((rows "20") (cols "79") (name "paste")))
+               (br)
+               (input ((type "submit") (value "Submit Paste")))))))))
+  (send/suspend/dispatch response-generator))
+
+(define (mk-rand-str)
+  (bytes->string/utf-8 (list->bytes (for/list ([n 4]) (+ 49 (random 9))))))
+(define (fresh-str)
+  (let loop ()
+    (define str (mk-rand-str))
+    (if (EXISTS str) (loop) str)))
+
+(define (process-paste request)
+  (define bs (request-bindings request))
+  (cond
+   [(exists-binding? 'paste bs)
+    (define str (fresh-str))
+    (define paste-url (+++ paste-url-base str))
+    (SET str (extract-binding/single 'paste bs))
+    (response/xexpr
+     `(html ()
+        (head ()
+          (script () ,(+++ "top.location.href=\"" paste-url "\"")))
+        (body ())))]
+   [else
+    (response/xexpr
+     `(html ()
+        (head ())
+        (body () "ERROR" ,(mk-link pastebin-url "Go Back"))))]))
+
+(define (serve-paste request pastenum)
+  (define code (GET/str pastenum))
+  (cond
+   [(not code)
+    (response/xexpr
+     `(html() (head ())
+        (body ()
+         ,(format "Paste # ~a doesn't exist." pastenum) (br)
+         ,(mk-link pastebin-url "Go Back"))))]
+   [else
+    (compile-scribble-file code)
+    (define doc
+      (document-element (with-input-from-file tmp-html-file read-xml)))
+    (define paste-url (string-append paste-url-base pastenum))
+    (response/xexpr
+     `(html ()
+        (head ()
+          (meta ((content "text-html; charset=utf-8")
+                 (http-equiv "content-type")))
+          (title ())
+          (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")))
+        (script ((src "/scribble-common.js")  (type "text/javascript"))))
+      (body
+       ((id "scribble-racket-lang-org"))
+       "Paste # " (a ((href ,paste-url)) ,pastenum)
+       (div ((class "maincolumn"))
+         (div ((class "main"))
+           (blockquote ((class "SCodeFlow"))
+            ,(se-path* '(blockquote) (xml->xexpr doc))))))))]))
+
+(define-values (do-dispatch mk-url)
+  (dispatch-rules
+   [("") serve-home]
+   [("pastes" (string-arg)) serve-paste]
+   #;[else serve-home]))
+
+(current-redis-connection (connect))
+
+(define (start request) (do-dispatch request))
+
+(require web-server/servlet-env)
+(serve/servlet start
+               #:launch-browser? #f
+               #:quit? #f
+               #:listen-ip #f
+               #:port 8000
+               #:extra-files-paths (list htdocs-dir)
+               #:servlet-path "/"
+               #:servlet-regexp #rx".*")