dont crash site when recent paste gets deleted

closes #40

.gitignore

@@ -0,0 +1 @@
+htdocs/*

README.md

@@ -3,4 +3,4 @@ pasterack
 
 An evaluating [pastebin](http://www.pasterack.org) for Racket.
 
-pkg dependencies: ring-buffer, redis, irc
+pkg dependencies: ring-buffer, redis, irc, memoize

filter-pastes.rkt

@@ -0,0 +1,69 @@
+#lang racket
+(require redis)
+
+;; delete all non-hash vals (ie, not pastes)
+(define (delete-nonpastes #:trial? [trial? #f])
+  (for ([k (KEYS "*")])
+    ; delete non-hashes
+    (unless (string=? (TYPE k) "hash")
+      (printf "deleting non-hash key: ~a\n" k)
+      (unless trial? (DEL k)))
+    ; delete hashes that are not pastes
+    (unless (HEXISTS k 'code)
+      (printf "deleting non-paste hash key: ~a\n" k)
+      (unless trial? (DEL k)))))
+
+; deletes pastes satisfying the given regexp pattern
+(define (delete-pastes/pat pat #:trial? [trial? #f])
+  (define count 0)
+  (define ci-pat (pregexp (string-append "(?i:" pat ")")))
+  (printf "searching for pastes with pattern: ~a" pat)
+  (when trial? (printf " (trial)"))
+  (printf "\n")
+  (for ([k (KEYS "*")])
+    (when (and (string=? (TYPE k) "hash") (HEXISTS k 'code)) ; valid paste
+      (define paste-contents (HGET/str k 'code))
+      (define paste-dir (build-path "tmp" (bytes->path k)))
+      (when (regexp-match ci-pat paste-contents)
+        (printf "deleting paste: ~a\n" k)
+;        (displayln paste-contents)
+        (when (directory-exists? paste-dir)
+          (printf "... and deleting directory: ~a\n" paste-dir))
+        (unless trial?
+          (DEL k)
+          (when (directory-exists? paste-dir)
+            (delete-directory/files paste-dir)))
+        (set! count (add1 count)))))
+  (printf "deleted ~a pastes matching pattern ~a\n" count pat))
+
+(define default-pats
+  '("amex"
+    "visa"
+    "mastercard"
+    "discover"
+    "rapidgator"
+    "turbobit"
+    "bitcoin"
+    "paypal"
+    "Western Union"
+    "Money Gram"
+    "wmz"
+    "cvv"
+    "Web Money"
+    "Perfect Money"
+    "torrent"
+    "hacked"
+    "accounts"
+    "premium"))
+
+(module+ main
+  (define trial-mode (make-parameter #t))
+  (define pats
+    (command-line
+     #:once-each
+     [("--delete") "Do the deletions (default is trial mode)"
+      (trial-mode #f)]
+     #:args args
+     (if (null? args) default-pats args)))
+  (for ([p pats])
+    (delete-pastes/pat p #:trial? (trial-mode))))

htdocs/codemirror.css

@@ -0,0 +1,334 @@
+/* BASICS */
+
+.CodeMirror {
+  /* Set height, width, borders, and global font properties here */
+  font-family: monospace;
+  height: 300px;
+  color: black;
+}
+
+/* PADDING */
+
+.CodeMirror-lines {
+  padding: 4px 0; /* Vertical padding around content */
+}
+.CodeMirror pre {
+  padding: 0 4px; /* Horizontal padding of content */
+}
+
+.CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler {
+  background-color: white; /* The little square between H and V scrollbars */
+}
+
+/* GUTTER */
+
+.CodeMirror-gutters {
+  border-right: 1px solid #ddd;
+  background-color: #f7f7f7;
+  white-space: nowrap;
+}
+.CodeMirror-linenumbers {}
+.CodeMirror-linenumber {
+  padding: 0 3px 0 5px;
+  min-width: 20px;
+  text-align: right;
+  color: #999;
+  white-space: nowrap;
+}
+
+.CodeMirror-guttermarker { color: black; }
+.CodeMirror-guttermarker-subtle { color: #999; }
+
+/* CURSOR */
+
+.CodeMirror-cursor {
+  border-left: 1px solid black;
+  border-right: none;
+  width: 0;
+}
+/* Shown when moving in bi-directional text */
+.CodeMirror div.CodeMirror-secondarycursor {
+  border-left: 1px solid silver;
+}
+.cm-fat-cursor .CodeMirror-cursor {
+  width: auto;
+  border: 0;
+  background: #7e7;
+}
+.cm-fat-cursor div.CodeMirror-cursors {
+  z-index: 1;
+}
+
+.cm-animate-fat-cursor {
+  width: auto;
+  border: 0;
+  -webkit-animation: blink 1.06s steps(1) infinite;
+  -moz-animation: blink 1.06s steps(1) infinite;
+  animation: blink 1.06s steps(1) infinite;
+  background-color: #7e7;
+}
+@-moz-keyframes blink {
+  0% {}
+  50% { background-color: transparent; }
+  100% {}
+}
+@-webkit-keyframes blink {
+  0% {}
+  50% { background-color: transparent; }
+  100% {}
+}
+@keyframes blink {
+  0% {}
+  50% { background-color: transparent; }
+  100% {}
+}
+
+/* Can style cursor different in overwrite (non-insert) mode */
+.CodeMirror-overwrite .CodeMirror-cursor {}
+
+.cm-tab { display: inline-block; text-decoration: inherit; }
+
+.CodeMirror-ruler {
+  border-left: 1px solid #ccc;
+  position: absolute;
+}
+
+/* DEFAULT THEME */
+
+.cm-s-default .cm-header {color: blue;}
+.cm-s-default .cm-quote {color: #090;}
+.cm-negative {color: #d44;}
+.cm-positive {color: #292;}
+.cm-header, .cm-strong {font-weight: bold;}
+.cm-em {font-style: italic;}
+.cm-link {text-decoration: underline;}
+.cm-strikethrough {text-decoration: line-through;}
+
+.cm-s-default .cm-keyword {color: #708;}
+.cm-s-default .cm-atom {color: #219;}
+.cm-s-default .cm-number {color: #164;}
+.cm-s-default .cm-def {color: #00f;}
+.cm-s-default .cm-variable,
+.cm-s-default .cm-punctuation,
+.cm-s-default .cm-property,
+.cm-s-default .cm-operator {}
+.cm-s-default .cm-variable-2 {color: #05a;}
+.cm-s-default .cm-variable-3 {color: #085;}
+.cm-s-default .cm-comment {color: #a50;}
+.cm-s-default .cm-string {color: #a11;}
+.cm-s-default .cm-string-2 {color: #f50;}
+.cm-s-default .cm-meta {color: #555;}
+.cm-s-default .cm-qualifier {color: #555;}
+.cm-s-default .cm-builtin {color: #30a;}
+.cm-s-default .cm-bracket {color: #997;}
+.cm-s-default .cm-tag {color: #170;}
+.cm-s-default .cm-attribute {color: #00c;}
+.cm-s-default .cm-hr {color: #999;}
+.cm-s-default .cm-link {color: #00c;}
+
+.cm-s-default .cm-error {color: #f00;}
+.cm-invalidchar {color: #f00;}
+
+.CodeMirror-composing { border-bottom: 2px solid; }
+
+/* Default styles for common addons */
+
+div.CodeMirror span.CodeMirror-matchingbracket {color: #0f0;}
+div.CodeMirror span.CodeMirror-nonmatchingbracket {color: #f22;}
+.CodeMirror-matchingtag { background: rgba(255, 150, 0, .3); }
+.CodeMirror-activeline-background {background: #e8f2ff;}
+
+/* STOP */
+
+/* The rest of this file contains styles related to the mechanics of
+   the editor. You probably shouldn't touch them. */
+
+.CodeMirror {
+  position: relative;
+  overflow: hidden;
+  background: white;
+}
+
+.CodeMirror-scroll {
+  overflow: scroll !important; /* Things will break if this is overridden */
+  /* 30px is the magic margin used to hide the element's real scrollbars */
+  /* See overflow: hidden in .CodeMirror */
+  margin-bottom: -30px; margin-right: -30px;
+  padding-bottom: 30px;
+  height: 100%;
+  outline: none; /* Prevent dragging from highlighting the element */
+  position: relative;
+}
+.CodeMirror-sizer {
+  position: relative;
+  border-right: 30px solid transparent;
+}
+
+/* The fake, visible scrollbars. Used to force redraw during scrolling
+   before actuall scrolling happens, thus preventing shaking and
+   flickering artifacts. */
+.CodeMirror-vscrollbar, .CodeMirror-hscrollbar, .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler {
+  position: absolute;
+  z-index: 6;
+  display: none;
+}
+.CodeMirror-vscrollbar {
+  right: 0; top: 0;
+  overflow-x: hidden;
+  overflow-y: scroll;
+}
+.CodeMirror-hscrollbar {
+  bottom: 0; left: 0;
+  overflow-y: hidden;
+  overflow-x: scroll;
+}
+.CodeMirror-scrollbar-filler {
+  right: 0; bottom: 0;
+}
+.CodeMirror-gutter-filler {
+  left: 0; bottom: 0;
+}
+
+.CodeMirror-gutters {
+  position: absolute; left: 0; top: 0;
+  z-index: 3;
+}
+.CodeMirror-gutter {
+  white-space: normal;
+  height: 100%;
+  display: inline-block;
+  margin-bottom: -30px;
+  /* Hack to make IE7 behave */
+  *zoom:1;
+  *display:inline;
+}
+.CodeMirror-gutter-wrapper {
+  position: absolute;
+  z-index: 4;
+  background: none !important;
+  border: none !important;
+}
+.CodeMirror-gutter-background {
+  position: absolute;
+  top: 0; bottom: 0;
+  z-index: 4;
+}
+.CodeMirror-gutter-elt {
+  position: absolute;
+  cursor: default;
+  z-index: 4;
+}
+.CodeMirror-gutter-wrapper {
+  -webkit-user-select: none;
+  -moz-user-select: none;
+  user-select: none;
+}
+
+.CodeMirror-lines {
+  cursor: text;
+  min-height: 1px; /* prevents collapsing before first draw */
+}
+.CodeMirror pre {
+  /* Reset some styles that the rest of the page might have set */
+  -moz-border-radius: 0; -webkit-border-radius: 0; border-radius: 0;
+  border-width: 0;
+  background: transparent;
+  font-family: inherit;
+  font-size: inherit;
+  margin: 0;
+  white-space: pre;
+  word-wrap: normal;
+  line-height: inherit;
+  color: inherit;
+  z-index: 2;
+  position: relative;
+  overflow: visible;
+  -webkit-tap-highlight-color: transparent;
+}
+.CodeMirror-wrap pre {
+  word-wrap: break-word;
+  white-space: pre-wrap;
+  word-break: normal;
+}
+
+.CodeMirror-linebackground {
+  position: absolute;
+  left: 0; right: 0; top: 0; bottom: 0;
+  z-index: 0;
+}
+
+.CodeMirror-linewidget {
+  position: relative;
+  z-index: 2;
+  overflow: auto;
+}
+
+.CodeMirror-widget {}
+
+.CodeMirror-code {
+  outline: none;
+}
+
+/* Force content-box sizing for the elements where we expect it */
+.CodeMirror-scroll,
+.CodeMirror-sizer,
+.CodeMirror-gutter,
+.CodeMirror-gutters,
+.CodeMirror-linenumber {
+  -moz-box-sizing: content-box;
+  box-sizing: content-box;
+}
+
+.CodeMirror-measure {
+  position: absolute;
+  width: 100%;
+  height: 0;
+  overflow: hidden;
+  visibility: hidden;
+}
+
+.CodeMirror-cursor { position: absolute; }
+.CodeMirror-measure pre { position: static; }
+
+div.CodeMirror-cursors {
+  visibility: hidden;
+  position: relative;
+  z-index: 3;
+}
+div.CodeMirror-dragcursors {
+  visibility: visible;
+}
+
+.CodeMirror-focused div.CodeMirror-cursors {
+  visibility: visible;
+}
+
+.CodeMirror-selected { background: #d9d9d9; }
+.CodeMirror-focused .CodeMirror-selected { background: #d7d4f0; }
+.CodeMirror-crosshair { cursor: crosshair; }
+.CodeMirror-line::selection, .CodeMirror-line > span::selection, .CodeMirror-line > span > span::selection { background: #d7d4f0; }
+.CodeMirror-line::-moz-selection, .CodeMirror-line > span::-moz-selection, .CodeMirror-line > span > span::-moz-selection { background: #d7d4f0; }
+
+.cm-searching {
+  background: #ffa;
+  background: rgba(255, 255, 0, .4);
+}
+
+/* IE7 hack to prevent it from returning funny offsetTops on the spans */
+.CodeMirror span { *vertical-align: text-bottom; }
+
+/* Used to force a border model for a node */
+.cm-force-border { padding-right: .1px; }
+
+@media print {
+  /* Hide the cursor when printing */
+  .CodeMirror div.CodeMirror-cursors {
+    visibility: hidden;
+  }
+}
+
+/* See issue #2901 */
+.cm-tab-wrap-hack:after { content: ''; }
+
+/* Help users use markselection to safely style text background */
+span.CodeMirror-selectedtext { background: none; }

htdocs/neat.css

@@ -0,0 +1,12 @@
+.cm-s-neat span.cm-comment { color: #a86; }
+.cm-s-neat span.cm-keyword { line-height: 1em; font-weight: bold; color: blue; }
+.cm-s-neat span.cm-string { color: #a22; }
+.cm-s-neat span.cm-builtin { line-height: 1em; font-weight: bold; color: #077; }
+.cm-s-neat span.cm-special { line-height: 1em; font-weight: bold; color: #0aa; }
+.cm-s-neat span.cm-variable { color: black; }
+.cm-s-neat span.cm-number, .cm-s-neat span.cm-atom { color: #3a3; }
+.cm-s-neat span.cm-meta { color: #555; }
+.cm-s-neat span.cm-link { color: #3a3; }
+
+.cm-s-neat .CodeMirror-activeline-background { background: #e8f2ff; }
+.cm-s-neat .CodeMirror-matchingbracket { outline:1px solid grey; color:black !important; }

htdocs/racket.css

@@ -0,0 +1,238 @@
+
+/* See the beginning of "scribble.css". */
+
+/* Monospace: */
+.RktIn, .RktRdr, .RktPn, .RktMeta,
+.RktMod, .RktKw, .RktVar, .RktSym,
+.RktRes, .RktOut, .RktCmt, .RktVal,
+.RktBlk {
+  font-family: 'Droid Sans Mono',monospace;
+  white-space: inherit;
+}
+
+/* Serif: */
+.inheritedlbl {
+  font-family: serif;
+}
+
+/* Sans-serif: */
+.RBackgroundLabelInner {
+  font-family: sans-serif;
+}
+
+/* ---------------------------------------- */
+/* Inherited methods, left margin */
+
+.inherited {
+  width: 100%;
+  margin-top: 0.5em;
+  text-align: left;
+  background-color: #ECF5F5;
+}
+
+.inherited td {
+  font-size: 82%;
+  padding-left: 1em;
+  text-indent: -0.8em;
+  padding-right: 0.2em;
+}
+
+.inheritedlbl {
+  font-style: italic;
+}
+
+/* ---------------------------------------- */
+/* Racket text styles */
+
+.RktIn {
+  color: #cc6633;
+  background-color: #eeeeee;
+}
+
+.RktInBG {
+  background-color: #eeeeee;
+}
+
+.RktRdr {
+}
+
+.RktPn {
+  color: #843c24;
+}
+
+.RktMeta {
+  color: black;
+}
+
+.RktMod {
+  color: black;
+}
+
+.RktOpt {
+  color: black;
+}
+
+.RktKw {
+  color: black;
+  /* font-weight: bold; */
+}
+
+.RktErr {
+  color: red;
+  font-style: italic;
+}
+
+.RktVar {
+  color: #262680;
+  font-style: italic;
+}
+
+.RktSym {
+  color: #262680;
+}
+
+.RktValLink {
+  text-decoration: none;
+  color: blue;
+}
+
+.RktModLink {
+  text-decoration: none;
+  color: blue;
+}
+
+.RktStxLink {
+  text-decoration: none;
+  color: black;
+  /* font-weight: bold; */
+}
+
+.RktRes {
+  color: #0000af;
+}
+
+.RktOut {
+  color: #960096;
+}
+
+.RktCmt {
+  color: #c2741f;
+}
+
+.RktVal {
+  color: #228b22;
+}
+
+/* ---------------------------------------- */
+/* Some inline styles */
+
+.together {
+  width: 100%;
+}
+
+.prototype, .argcontract, .RBoxed {
+  white-space: nowrap;
+}
+
+.prototype td {
+  vertical-align: text-top;
+}
+.longprototype td {
+  vertical-align: bottom;
+}
+
+.RktBlk {
+  white-space: inherit;
+  text-align: left;
+}
+
+.RktBlk tr {
+  white-space: inherit;
+}
+
+.RktBlk td {
+  vertical-align: baseline;
+  white-space: inherit;
+}
+
+.argcontract td {
+  vertical-align: text-top;
+}
+
+.highlighted {
+  background-color: #ddddff;
+}
+
+.defmodule {
+  width: 100%;
+  background-color: #F5F5DC;
+}
+
+.specgrammar {
+  float: right;
+}
+
+.RBibliography td {
+  vertical-align: text-top;
+}
+
+.leftindent {
+ margin-left: 1em;
+ margin-right: 0em;
+}
+
+.insetpara {
+ margin-left: 1em;
+ margin-right: 1em;
+}
+
+.Rfilebox {
+}
+
+.Rfiletitle {
+  text-align: right;
+  margin: 0em 0em 0em 0em;
+}
+
+.Rfilename {
+  border-top: 1px solid #6C8585;
+  border-right: 1px solid #6C8585;
+  padding-left: 0.5em;
+  padding-right: 0.5em;
+  background-color: #ECF5F5;
+}
+
+.Rfilecontent {
+  margin: 0em 0em 0em 0em;
+}
+
+.RpackageSpec {
+  padding-right: 0.5em;
+}
+
+/* ---------------------------------------- */
+/* For background labels */
+
+.RBackgroundLabel {
+   float: right;
+   width: 0px;
+   height: 0px;
+}
+
+.RBackgroundLabelInner {
+   position: relative;
+   width: 25em;
+   left: -25.5em;
+   top: 0px;
+   text-align: right;
+   color: white;
+   z-index: 0;
+   font-weight: bold;
+}
+
+.RForeground {
+   position: relative;
+   left: 0px;
+   top: 0px;
+   z-index: 1;
+}

htdocs/scribble-common.js

@@ -0,0 +1,153 @@
+// Common functionality for PLT documentation pages
+
+// Page Parameters ------------------------------------------------------------
+
+var page_query_string =
+  (location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1;
+
+var page_args =
+  ((function(){
+      if (!page_query_string) return [];
+      var args = page_query_string.split(/[&;]/);
+      for (var i=0; i<args.length; i++) {
+        var a = args[i];
+        var p = a.indexOf('=');
+        if (p >= 0) args[i] = [a.substring(0,p), a.substring(p+1)];
+        else args[i] = [a, false];
+      }
+      return args;
+    })());
+
+function GetPageArg(key, def) {
+  for (var i=0; i<page_args.length; i++)
+    if (page_args[i][0] == key) return unescape(page_args[i][1]);
+  return def;
+}
+
+function MergePageArgsIntoLink(a) {
+  if (page_args.length == 0 ||
+      (!a.attributes["data-pltdoc"]) || (a.attributes["data-pltdoc"].value == ""))
+    return;
+  a.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
+  if (RegExp.$2.length == 0) {
+    a.href = RegExp.$1 + "?" + page_query_string + RegExp.$3;
+  } else {
+    // need to merge here, precedence to arguments that exist in `a'
+    var i, j;
+    var prefix = RegExp.$1, str = RegExp.$2, suffix = RegExp.$3;
+    var args = str.split(/[&;]/);
+    for (i=0; i<args.length; i++) {
+      j = args[i].indexOf('=');
+      if (j) args[i] = args[i].substring(0,j);
+    }
+    var additions = "";
+    for (i=0; i<page_args.length; i++) {
+      var exists = false;
+      for (j=0; j<args.length; j++)
+        if (args[j] == page_args[i][0]) { exists = true; break; }
+      if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
+    }
+    a.href = prefix + "?" + str + suffix;
+  }
+}
+
+// Cookies --------------------------------------------------------------------
+
+function GetCookie(key, def) {
+  var i, cookiestrs;
+  try {
+    if (document.cookie.length <= 0) return def;
+    cookiestrs = document.cookie.split(/; */);
+  } catch (e) { return def; }
+  for (i = 0; i < cookiestrs.length; i++) {
+    var cur = cookiestrs[i];
+    var eql = cur.indexOf('=');
+    if (eql >= 0 && cur.substring(0,eql) == key)
+      return unescape(cur.substring(eql+1));
+  }
+  return def;
+}
+
+function SetCookie(key, val) {
+  var d = new Date();
+  d.setTime(d.getTime()+(365*24*60*60*1000));
+  try {
+    document.cookie =
+      key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/";
+  } catch (e) {}
+}
+
+// note that this always stores a directory name, ending with a "/"
+function SetPLTRoot(ver, relative) {
+  var root = location.protocol + "//" + location.host
+           + NormalizePath(location.pathname.replace(/[^\/]*$/, relative));
+  SetCookie("PLT_Root."+ver, root);
+}
+
+// adding index.html works because of the above
+function GotoPLTRoot(ver, relative) {
+  var u = GetCookie("PLT_Root."+ver, null);
+  if (u == null) return true; // no cookie: use plain up link
+  // the relative path is optional, default goes to the toplevel start page
+  if (!relative) relative = "index.html";
+  location = u + relative;
+  return false;
+}
+
+// Utilities ------------------------------------------------------------------
+
+var normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
+function NormalizePath(path) {
+  var tmp, i;
+  for (i = 0; i < normalize_rxs.length; i++)
+    while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp;
+  return path;
+}
+
+// `noscript' is problematic in some browsers (always renders as a
+// block), use this hack instead (does not always work!)
+// document.write("<style>mynoscript { display:none; }</style>");
+
+// Interactions ---------------------------------------------------------------
+
+function DoSearchKey(event, field, ver, top_path) {
+  var val = field.value;
+  if (event && event.keyCode == 13) {
+    var u = GetCookie("PLT_Root."+ver, null);
+    if (u == null) u = top_path; // default: go to the top path
+    u += "search/index.html?q=" + escape(val);
+    if (page_query_string) u += "&" + page_query_string;
+    location = u;
+    return false;
+  }
+  return true;
+}
+
+function TocviewToggle(glyph, id) {
+  var s = document.getElementById(id).style;
+  var expand = s.display == "none";
+  s.display = expand ? "block" : "none";
+  glyph.innerHTML = expand ? "&#9660;" : "&#9658;";
+}
+
+// Page Init ------------------------------------------------------------------
+
+// Note: could make a function that inspects and uses window.onload to chain to
+// a previous one, but this file needs to be required first anyway, since it
+// contains utilities for all other files.
+var on_load_funcs = [];
+function AddOnLoad(fun) { on_load_funcs.push(fun); }
+window.onload = function() {
+  for (var i=0; i<on_load_funcs.length; i++) on_load_funcs[i]();
+};
+
+AddOnLoad(function(){
+    var links = document.getElementsByTagName("a");
+    for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
+    var label = GetPageArg("ctxtname",false);
+    if (!label) return;
+    var indicator = document.getElementById("contextindicator");
+    if (!indicator) return;
+    indicator.innerHTML = label;
+    indicator.style.display = "block";
+  });

htdocs/scribble.css

@@ -0,0 +1,475 @@
+
+/* CSS seems backward: List all the classes for which we want a
+   particular font, so that the font can be changed in one place.  (It
+   would be nicer to reference a font definition from all the places
+   that we want it.)
+
+   As you read the rest of the file, remember to double-check here to
+   see if any font is set. */
+
+/* Monospace: */
+.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
+  font-family: 'Droid Sans Mono',monospace;
+}
+
+/* Serif: */
+.main, .refcontent, .tocview, .tocsub, .sroman, i {
+  font-family: serif;
+}
+
+/* Sans-serif: */
+.version, .versionNoNav, .ssansserif {
+  font-family: sans-serif;
+}
+.ssansserif {
+  font-size: 80%;
+  font-weight: bold;
+}
+
+/* ---------------------------------------- */
+
+p, .SIntrapara {
+  display: block;
+  margin: 1em 0;
+}
+
+h2 { /* per-page main title */
+  margin-top: 0;
+}
+
+h3, h4, h5, h6, h7, h8 {
+  margin-top: 1.75em;
+  margin-bottom: 0.5em;
+}
+
+.SSubSubSubSection {
+  font-weight: bold;
+  font-size: 0.83em; /* should match h5; from HTML 4 reference */
+}
+
+/* Needed for browsers like Opera, and eventually for HTML 4 conformance.
+   This means that multiple paragraphs in a table element do not have a space
+   between them. */
+table p {
+  margin-top: 0;
+  margin-bottom: 0;
+}
+
+/* ---------------------------------------- */
+/* Main */
+
+body {
+  color: black;
+  background-color: #ffffff;
+}
+
+table td {
+  padding-left: 0;
+  padding-right: 0;
+}
+
+.maincolumn {
+  width: 43em;
+  margin-right: -40em;
+  margin-left: 15em;
+}
+
+.main {
+  text-align: left;
+}
+
+/* ---------------------------------------- */
+/* Navigation */
+
+.navsettop, .navsetbottom {
+  background-color: #f0f0e0;
+  padding: 0.25em 0 0.25em 0;
+}
+
+.navsettop {
+  margin-bottom: 1.5em;
+  border-bottom: 2px solid #e0e0c0;
+}
+
+.navsetbottom {
+  margin-top: 2em;
+  border-top: 2px solid #e0e0c0;
+}
+
+.navleft {
+  margin-left: 1ex;
+  position: relative;
+  float: left;
+  white-space: nowrap;
+}
+.navright {
+  margin-right: 1ex;
+  position: relative;
+  float: right;
+  white-space: nowrap;
+}
+.nonavigation {
+  color: #e0e0e0;
+}
+
+.searchform {
+  display: inline;
+  margin: 0;
+  padding: 0;
+}
+
+.searchbox {
+  width: 16em;
+  margin: 0px;
+  padding: 0px;
+  background-color: #eee;
+  border: 1px solid #ddd;
+  text-align: center;
+  vertical-align: middle;
+}
+
+#contextindicator {
+  position: fixed;
+  background-color: #c6f;
+  color: #000;
+  font-family: 'Droid Sans mono',monospace;
+  font-weight: bold;
+  padding: 2px 10px;
+  display: none;
+  right: 0;
+  bottom: 0;
+}
+
+/* ---------------------------------------- */
+/* Version */
+
+.versionbox {
+  position: relative;
+  float: right;
+  left: 2em;
+  height: 0em;
+  width: 13em;
+  margin: 0em -13em 0em 0em;
+}
+.version {
+  font-size: small;
+}
+.versionNoNav {
+  font-size: xx-small; /* avoid overlap with author */
+}
+
+.version:before, .versionNoNav:before {
+  content: "Version ";
+}
+
+/* ---------------------------------------- */
+/* Margin notes */
+
+.refpara, .refelem {
+  position: relative;
+  float: right;
+  left: 2em;
+  height: 0em;
+  width: 13em;
+  margin: 0em -13em 0em 0em;
+}
+
+.refpara, .refparaleft {
+  top: -1em;
+}
+
+.refcolumn {
+  background-color: #F5F5DC;
+  display: block;
+  position: relative;
+  width: 13em;
+  font-size: 85%;
+  border: 0.5em solid #F5F5DC;
+  margin: 0 0 0 0;
+}
+
+.refcontent {
+  margin: 0 0 0 0;
+}
+
+.refcontent p {
+  margin-top: 0;
+  margin-bottom: 0;
+}
+
+.refparaleft, .refelemleft {
+  position: relative;
+  float: left;
+  right: 2em;
+  height: 0em;
+  width: 13em;
+  margin: 0em 0em 0em -13em;
+}
+
+.refcolumnleft {
+  background-color: #F5F5DC;
+  display: block;
+  position: relative;
+  width: 13em;
+  font-size: 85%;
+  border: 0.5em solid #F5F5DC;
+  margin: 0 0 0 0;
+}
+
+
+/* ---------------------------------------- */
+/* Table of contents, inline */
+
+.toclink {
+  text-decoration: none;
+  color: blue;
+  font-size: 85%;
+}
+
+.toptoclink {
+  text-decoration: none;
+  color: blue;
+  font-weight: bold;
+}
+
+/* ---------------------------------------- */
+/* Table of contents, left margin */
+
+.tocset {
+  position: relative;
+  float: left;
+  width: 12.5em;
+  margin-right: 2em;
+}
+.tocset td {
+  vertical-align: text-top;
+}
+
+.tocview {
+  text-align: left;
+  background-color: #f0f0e0;
+}
+
+.tocsub {
+  text-align: left;
+  margin-top: 0.5em;
+  background-color: #f0f0e0;
+}
+
+.tocviewlist, .tocsublist {
+  margin-left: 0.2em;
+  margin-right: 0.2em;
+  padding-top: 0.2em;
+  padding-bottom: 0.2em;
+}
+.tocviewlist table {
+  font-size: 82%;
+}
+
+.tocviewlisttopspace {
+  margin-bottom: 1em;
+}
+
+.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
+  margin-left: 0.4em;
+  border-left: 1px solid #bbf;
+  padding-left: 0.8em;
+}
+.tocviewsublist {
+  margin-bottom: 1em;
+}
+.tocviewsublist table,
+.tocviewsublistonly table,
+.tocviewsublisttop table,
+.tocviewsublistbottom table {
+  font-size: 75%;
+}
+
+.tocviewtitle * {
+  font-weight: bold;
+}
+
+.tocviewlink {
+  text-decoration: none;
+  color: blue;
+}
+
+.tocviewselflink {
+  text-decoration: underline;
+  color: blue;
+}
+
+.tocviewtoggle {
+  text-decoration: none;
+  color: blue;
+  font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
+}
+
+.tocsublist td {
+  padding-left: 1em;
+  text-indent: -1em;
+}
+
+.tocsublinknumber {
+  font-size: 82%;
+}
+
+.tocsublink {
+  font-size: 82%;
+  text-decoration: none;
+}
+
+.tocsubseclink {
+  font-size: 82%;
+  text-decoration: none;
+}
+
+.tocsubnonseclink {
+  font-size: 82%;
+  text-decoration: none;
+  padding-left: 0.5em;
+}
+
+.tocsubtitle {
+  font-size: 82%;
+  font-style: italic;
+  margin: 0.2em;
+}
+
+/* ---------------------------------------- */
+/* Some inline styles */
+
+.indexlink {
+  text-decoration: none;
+}
+
+.nobreak {
+  white-space: nowrap;
+}
+
+pre { margin-left: 2em; }
+blockquote { margin-left: 2em; }
+
+ol          { list-style-type: decimal; }
+ol ol       { list-style-type: lower-alpha; }
+ol ol ol    { list-style-type: lower-roman; }
+ol ol ol ol { list-style-type: upper-alpha; }
+
+.SCodeFlow {
+  display: block;
+  margin-left: 1em;
+  margin-bottom: 0em;
+  margin-right: 1em;
+  margin-top: 0em;
+  white-space: nowrap;  
+}
+
+.SVInsetFlow {
+  display: block;
+  margin-left: 0em;
+  margin-bottom: 0em;
+  margin-right: 0em;
+  margin-top: 0em;
+}
+
+.SubFlow {
+  display: block;
+  margin: 0em;
+}
+
+.boxed {
+  width: 100%;
+  background-color: #E8E8FF;
+}
+
+.hspace {
+}
+
+.slant {
+  font-style: oblique;
+}
+
+.badlink {
+  text-decoration: underline;
+  color: red;
+}
+
+.plainlink {
+  text-decoration: none;
+  color: blue;
+}
+
+.techoutside       { text-decoration: underline; color: #b0b0b0; }
+.techoutside:hover { text-decoration: underline; color: blue; }
+
+/* .techinside:hover doesn't work with FF, .techinside:hover>
+   .techinside doesn't work with IE, so use both (and IE doesn't
+   work with inherit in the second one, so use blue directly) */
+.techinside                    { color: black; }
+.techinside:hover              { color: blue; }
+.techoutside:hover>.techinside { color: inherit; }
+
+.SCentered {
+  text-align: center;
+}
+
+.imageleft {
+  float: left;
+  margin-right: 0.3em;
+}
+
+.Smaller {
+  font-size: 82%;
+  background-color: transparent;
+}
+
+.Larger {
+  font-size: 122%;
+}
+
+/* A hack, inserted to break some Scheme ids: */
+.mywbr {
+  width: 0;
+  font-size: 1px;
+}
+
+.compact li p {
+  margin: 0em;
+  padding: 0em;
+}
+
+.noborder img {
+  border: 0;
+}
+
+.SAuthorListBox {
+  position: relative;
+  float: right;
+  left: 2em;
+  top: -2.5em;
+  height: 0em;
+  width: 13em;
+  margin: 0em -13em 0em 0em;
+}
+.SAuthorList {
+  font-size: 82%;
+}
+.SAuthorList:before {
+  content: "by ";
+}
+.author {
+  display: inline;
+  white-space: nowrap;
+}
+
+/* print styles : hide the navigation elements */
+@media print {
+  .tocset,
+  .navsettop,
+  .navsetbottom { display: none; }
+  .maincolumn {
+    width: auto;
+    margin-right: 13em;
+    margin-left: 0;
+  }
+}

info.rkt

@@ -0,0 +1,3 @@
+#lang info
+
+(define deps '("ring-buffer" "irc" "redis" "memoize" "graph"))

irc-bot.rkt

@@ -0,0 +1,51 @@
+#lang racket/base
+(require irc racket/async-channel)
+(provide pasterack-irc-connect irc-paste)
+
+;; pasterack irc bot
+
+(define MIRROR? #f)
+
+(define FREENODE "chat.freenode.net")
+(define PORT 6667)
+(define NAME (if MIRROR? "pasteracktest" "pasterack"))
+
+
+(define irc-channels (if MIRROR? '("#racktest") '("#racket")))
+
+(define current-irc-connection #f)
+(define current-irc-listener (thread void))
+(define current-irc-monitor (thread void))
+  
+
+(define (irc-connect/internal)
+  (define-values (irc-connection ready)
+    (irc-connect FREENODE PORT NAME NAME NAME #:return-eof #t))
+  (define achan (irc-connection-incoming irc-connection))
+  (set! current-irc-connection irc-connection)
+  (set! current-irc-listener
+    (thread
+        (lambda ()
+          (let loop ()
+            (unless (eof-object? (async-channel-get achan))
+              (loop))))))
+  ready)
+
+;; creates an irc monitor thread
+(define (pasterack-irc-connect)
+  (set! current-irc-monitor
+      (thread
+          (lambda ()
+            (let loop ()
+              (when (thread-dead? current-irc-listener)
+                (sync (irc-connect/internal))
+                (join-channels))
+              (sleep 60)
+              (loop))))))
+
+(define (join-channels)
+  (for ([c irc-channels]) (irc-join-channel current-irc-connection c)))
+
+(define (irc-paste msg)
+  (for ([c irc-channels]) (irc-send-message current-irc-connection c msg)))
+              

pasterack-parsing-utils.rkt

@@ -12,11 +12,16 @@
 (define scribblelang-pat #px"^scribble/.*")
 (define htdplang-pat #px"^htdp/(.*)")
 (define TRlang-pat #px"^typed/racket.*")
+(define plai-pat #px"^plai.*")
 
 (define (hashlang? code)
   (define in (open-input-string code))
   (begin0 (read-language in (lambda () #f)) (close-input-port in)))
 
+;; Returns #t if str has "#lang" somewhere.
+(define (has-hashlang? str)
+  (regexp-match "#lang" str))
+
 ;; ie maps htdp/bsl -> lang/htdp-beginner
 (define (htdplang->modulename lang)
   (match (cadr (regexp-match htdplang-pat lang))
@@ -37,6 +42,7 @@
 (define (htdp-lang? lang) (regexp-match htdplang-pat lang))
 (define (TR-lang? lang) (regexp-match TRlang-pat lang))
 (define (web-lang? lang) (regexp-match weblang-pat lang))
+(define (plai-lang? lang) (regexp-match plai-pat lang))
 
 ;; htdp form patterns
 (define provide-pat #px"^\\(provide (.*)\\)$")

pasterack-test-cases.rkt

@@ -39,5 +39,9 @@
     "8757" ; out of order defines
     "5795" ; #lang blank
     "4662" ; blank
+    "4126" ; nested list of images
+    "5791" ; list of images (thanks jrslepak)
+    "5568" ; plai
+    "29314"; fish pict
     ;; BROKEN: submodule evaluation
     ))

pasterack-utils.rkt

@@ -9,7 +9,7 @@
 (define (to-string/s d) (format "~s" d))
 
 (define (mk-rand-str)
-  (number->string (random 10000)))
+  (number->string (random 100000)))
 ;  (bytes->string/utf-8 (list->bytes (for/list ([n 4]) (+ 49 (random 9))))))
 
 (define (get-time/iso8601)
@@ -25,3 +25,12 @@
 
 ;; stx utils
 (define (stx->string stx) (to-string/s (syntax->datum stx)))
+
+
+;; string-truncate : String -> String
+;; Truncates the given str to len-limit chars,
+;; or returns str unchanged if its length is <= len-limit
+(define (string-truncate str len-limit)
+  (if (<= (string-length str) len-limit)
+      str
+      (substring str 0 len-limit)))

pasterack.rkt

@@ -2,15 +2,12 @@
 
 (require web-server/servlet web-server/dispatch
          web-server/http/request-structs)
-(require xml xml/path)
+(require xml xml/path net/url net/uri-codec json "recaptcha.rkt"
+         "spam.rkt")
 (require racket/system racket/runtime-path)
 (require redis data/ring-buffer)
 (require "pasterack-utils.rkt" "pasterack-parsing-utils.rkt"
-         "pasterack-test-cases.rkt")
-
-;; irc bot
-(require irc)
-(require racket/async-channel)
+         "pasterack-test-cases.rkt" "irc-bot.rkt")
 
 (provide/contract (start (request? . -> . response?)))
 
@@ -26,8 +23,10 @@
 (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 scrbl-exe "/home/stchang/pltpkg/racket/bin/scribble")
+(define scrbl-exe "/home/pasterack/racket63/bin/scribble")
+;(define scrbl-exe "/home/stchang/racket-6.2.0.3/bin/scribble")
+
+(define PASTE-TITLE-DISPLAY-LEN 32) ; limit length of displayed title
 
 (define (mk-paste-url paste-num) (++ paste-url-base paste-num))
 
@@ -41,14 +40,7 @@
 (define log-file (build-path here-dir "pasterack.log"))
 (define log-port (open-output-file log-file #:mode 'text #:exists 'append))
 
-;irc bot
-(define-values (irc-connection ready)
-;  (irc-connect "card.freenode.net" 6667 "pasterackm" "pasterackm" "pasterack.org mirror"))
-  (irc-connect "card.freenode.net" 6667 "pasterack" "pasterack" "pasterack.org"))
-(sync ready)
-;(define irc-channels '("#racktest"))
-(define irc-channels '("#racket"))
-(for ([chan irc-channels]) (irc-join-channel irc-connection chan))
+(pasterack-irc-connect)
 
 (define sample-pastes
   '("8953" ; Sierpinski
@@ -59,7 +51,9 @@
     "7435" ; #lang htdp/bsl + 2htdp/image
     "3883" ; echo serv, test limits, and forms in racket but not racket/base
     "7658" ; typed/racket
-    "5873")) ; plot
+    "97561"; plot
+    "29314"; fish pict
+    ))
 
 (define sample-pastes-htmls
   (let ([ns (with-redis-connection
@@ -75,7 +69,13 @@
 
 (define TR-bad-ids
   (++ "#%module-begin with-handlers lambda λ #%top-interaction for for* "
-      "define default-continuation-prompt-tag"))
+      "define default-continuation-prompt-tag struct case-lambda let-values "
+      "letrec-values for*/product let let* letrec define-struct for*/lists "
+      "for*/hasheqv let/cc do for/and for/sum for/hasheq for/lists for*/and "
+      "for*/hasheq for*/vector for/or for/hasheqv for*/last for*/or for/last "
+      "for*/sum for/first for*/fold for/product for/hash for*/list let/ec "
+      "for/list for/vector for*/hash for/fold for*/first let*-values"))
+(define plai-bad-ids "#%module-begin provide")
 
 ;; returns generated pastenum
 (define (write-codeblock-scrbl-file code pnum)
@@ -84,7 +84,7 @@
   (define lang-lst
     (cond [(scribble-lang? lang) (list "racket" lang)]
           [(htdp-lang? lang) (list (htdplang->modulename lang))]
-          [(TR-lang? lang) (list)]
+          [(or (TR-lang? lang) (plai-lang? lang)) (list)]
           [(web-lang? lang) (list "web-server" "web-server/http")]
           [else (list lang)]))
   (define reqs   
@@ -108,6 +108,9 @@
            [(TR-lang? lang)
             (++ "(except-in typed/racket " TR-bad-ids ")\n"
                 "(only-meta-in 0 (only-in typed/racket " TR-bad-ids "))\n")]
+           [(plai-lang? lang)
+            (++ "(except-in plai " plai-bad-ids ")\n"
+                "(only-meta-in 0 (only-in plai " plai-bad-ids "))\n")]
             [else ""])
           ;; when required id is also in lang, favor require
           (cond
@@ -153,9 +156,11 @@
                             "(lambda () (namespace-anchor->namespace anchor)) "
                             "'(racket/pretty file/convertible))]\n"
            "                    [sandbox-path-permissions "
-                         "'([read \"/home/stchang/racket/pasterack/tmp/\"]\n"
+                         "'([read \"/home/pasterack/pasterack/tmp/\"]\n"
                          ;; images seem to need access to the prefs file
-                           "[read \"/home/stchang/.racket/\"])]\n"
+                           "[read \"/home/pasterack/.racket/\"]\n"
+                           ;; 2htdp/image performs exists? checks on libpng
+                           "[exists \"/\"])]\n"
            "                    [sandbox-eval-limits '(20 128)])\n"
            "        (let ([e (make-module-evaluator "
            "'(module m " lang-name
@@ -195,8 +200,10 @@
                             "(lambda () (namespace-anchor->namespace anchor)) "
                             "'(racket/pretty file/convertible))]\n"
              "                    [sandbox-path-permissions "
-                         "'([read \"/home/stchang/racket/pasterack/tmp/\"]"
-                           "[read \"/home/stchang/.racket/\"])]\n"
+                         "'([read \"/home/pasterack/pasterack/tmp/\"]"
+                           "[read \"/home/pasterack/.racket/\"]\n"
+                           ;; 2htdp/image performs exists? checks on libpng
+                           "[exists \"/\"])]\n"
              "                     [sandbox-eval-limits '(20 128)])\n"
 ;           "        (let ([e (make-evaluator '" lang ")])\n"
            "        (let ([e (make-module-evaluator "
@@ -282,6 +289,11 @@
       "fjs.parentNode.insertBefore(js,fjs);}}"
       "(document, 'script', 'twitter-wjs');"))
 
+(define codemirror-script
+  "var codeMirror = CodeMirror.fromTextArea(document.getElementById(\"paste\"),\
+     { lineNumbers : true, matchBrackets : true, theme: \"neat\" }
+   );")
+
 (define droidsansmono-css/x
   '(link ([type "text/css"] [rel "stylesheet"]
           [href "http://fonts.googleapis.com/css?family=Droid+Sans+Mono"])))
@@ -329,8 +341,17 @@
        (head
 ;        (title "PasteRack (MIRROR): A Racket-evaluating pastebin")
         (title "PasteRack: A Racket-evaluating pastebin")
-        (script ((type "text/javascript")) ,google-analytics-script)
+        (script ([type "text/javascript"]) ,google-analytics-script)
+        (script ([src "https://www.google.com/recaptcha/api.js"]))
 	,droidsansmono-css/x ,ptsans-css/x
+        ;; expects a codemirror.js script and its scheme mode in htdocs
+        (script ([src "/codemirror.js"] [type "text/javascript"]))
+        (link ((rel "stylesheet") (href "/codemirror.css")))
+        (link ((rel "stylesheet") (href "/neat.css")))
+        (style ,(string-append ".CodeMirror { text-align: left; background: #FFFFF0;"
+                               " font-size: 15px; height: 35em;"
+                               " font-family: Droid Sans Mono, monospace;"
+                               " border: thin gray inset; width: 50em; }"))
 	)
        ;; body ----------------------------------------------------------------
        (body ((style "font-family:'PT Sans',sans-serif"))
@@ -347,10 +368,13 @@
           (table ((style "margin-top:-15px;font-size:95%"))
           ,@(reverse
              (with-redis-connection
-              (for/list ([pnum recent-pastes] #:when pnum)
+               (for/list ([pnum recent-pastes] #:when pnum
+                          #:when (HGET/str pnum 'name))
                 (define name (HGET/str pnum 'name))
+                (define trunc-name
+                  (string-truncate name PASTE-TITLE-DISPLAY-LEN))
                 `(tr (td ,(mk-link (mk-paste-url pnum) pnum))
-                     (td ((style "width:1px"))) (td ,name)))))))
+                     (td ((style "width:1px"))) (td ,trunc-name)))))))
         ;; middle ------------------------------------------------------------
         (div ((style ,(~~ "position:absolute;left:14em;top:2em")))
          (center
@@ -358,7 +382,7 @@
           (h2 ,(mk-link pastebin-url "PasteRack")
               ": An evaluating pastebin for "
               ,(mk-link racket-lang-url "Racket") ".")
-          (form ((action ,(embed/url process-paste)) (method "post"))
+          (form ([action ,(embed/url check-paste)] [method "post"])
             (div 
               (input ([type "text"] [name "name"] [size "60"] [value ,title]
                       [style ,(~~ "background-color:#FFFFF0"
@@ -366,20 +390,14 @@
                                   "font-size:105%"
                                   "font-family:'PT Sans',sans-serif")]))
               (span ([style "font-size:90%"]) " (paste title)"))
-            (textarea ([style ,(~~ "font-family:'Droid Sans Mono',monospace"
-                                   "background-color:#FFFFF0"
-                                   "border:inset"
-                                   "border-width:thin"
-                                   "height:32em" "width:50em")]
-                       [name "paste"]) ,content)
+            (br)
+            (textarea ([id "paste"] [name "paste"]) ,content)
+            ;; run script after textarea is evaluated
+            (script ([type "text/javascript"]) ,codemirror-script)
             (input ([type "hidden"] [name "fork-from"] [value ,fork-from]))
             (br)
             (table (tr
-              (td ((style "width:12em")))
-              ;; as-text checkbox ----------
-              (td (input ([type "checkbox"] [name "astext"] [value "off"])))
-              (td ((style "font-size:90%")) " Submit as text only")
-              (td ((style "width:10px")))
+              (td ((style "width:18em")))
               ;; submit button -------------
               (td ((style "width:5em"))
                   (input ([type "image"] [alt "Submit Paste and Run"]
@@ -388,22 +406,25 @@
               (td ((style "font-size:90%"))
                   (input ([type "checkbox"] [name "irc"] [value "off"]))
                   (span " Alert "
-                       ,(mk-link racket-irc-url "#racket")
-                       " channel; your name/nick: ")
+                       ,(mk-link racket-irc-url "#racket") "; your nick: ")
                   (input ([type "text"] [name "nick"] [size "10"]
                           [style ,(~~ "background-color:#FFFFF0"
                                       "border:inset thin"
                                       "font-size:105%"
-                                      "font-family:'PT Sans',sans-serif")])))
-              )
-              (tr (td ([colspan "3"])) (td ([colspan "3"]) ,status))
-              ;; status message
-              (tr (td ([colspan "3"])) (td ([colspan "3"])
-                      ,(if (string=? "" fork-from) ""
-                          `(span "Forked from paste # " ,fork-from))))))
+                                      "font-family:'PT Sans',sans-serif")])))))
+            (span ,status)
+            (br)
+            (span ,(if (string=? "" fork-from) ""
+                       `(span "Forked from paste # " 
+                         ,(mk-link 
+                              (++ paste-url-base fork-from) fork-from))))
+            (br)
+            (div ([class "g-recaptcha"] 
+                  [data-sitekey "6LdM0wYTAAAAAJPls_eNV28XvCRMeaf1cDoAV4Qx"])
+              "To paste as plaintext, check the box:"))
          (br)(br)(br)
          ;; middle bottom (part of middle) ------------------------------------
-         (div ((style "font-size:small;color:#808080"))
+         (div ([style "font-size:small;color:#808080"])
            "Powered by " ,(mk-link racket-lang-url "Racket") ". "
            "View "
            ,(mk-link "https://github.com/stchang/pasterack" "source") "."
@@ -416,7 +437,36 @@
          ))))
   (send/suspend/dispatch response-generator))
 
-(define (process-paste request)
+(define (check-paste request)
+  (define bs (request-bindings request))
+  (define name (extract-binding/single 'name bs))
+  (define captcha-token (extract-binding/single 'g-recaptcha-response bs))
+  (define paste-content (extract-binding/single 'paste bs))
+  (define fork-from (extract-binding/single 'fork-from bs))
+  (define-values (status headers captcha-success-in)
+    (http-sendrecv/url 
+      (string->url "https://www.google.com/recaptcha/api/siteverify")
+      #:method "POST"
+      #:data (alist->form-urlencoded
+               (list (cons 'secret RECAPTCHA-SECRET)
+                     (cons 'response captcha-token)
+                     (cons 'remoteip (request-client-ip request))))
+      #:headers '("Content-Type: application/x-www-form-urlencoded")))
+  (define as-text? (hash-ref (read-json captcha-success-in) 'success #f))
+  ;; very basic spam filter TODO: move check to client-side?
+  (if (and ;; probably spam
+           (or (not as-text?)
+               (check-ip (request-client-ip request)))
+           (not (has-hashlang? paste-content)))
+      (serve-home request 
+                  #:title name
+                  #:content paste-content
+                  #:fork-from fork-from
+                  #:status '(span "Invalid paste: must include #lang." (br)
+                             "Or check the box to paste as plaintext."))
+      (process-paste request as-text?)))
+
+(define (process-paste request [as-text? #f])
   (define bs (request-bindings request))
   (cond
    [(exists-binding? 'paste bs)
@@ -425,8 +475,7 @@
     (define pasted-code (extract-binding/single 'paste bs))
     (define fork-from (extract-binding/single 'fork-from bs))
     (define html-res
-      (if (exists-binding? 'astext bs) #f
-          (generate-paste-html pasted-code paste-num)))
+      (if as-text? #f (generate-paste-html pasted-code paste-num)))
     (define paste-html-str (or html-res pasted-code))
     (define eval-html-str
       (if html-res
@@ -434,7 +483,7 @@
           (generate-eval-html pasted-code paste-num)
           ;; if not, use read error as output,
           ;; unless as-text was explicitly checked
-          (if (exists-binding? 'astext bs) #f
+          (if as-text? #f
               (with-input-from-file
                 (build-path tmp-dir paste-num (++ paste-num "code.err"))
                 port->string))))
@@ -450,18 +499,12 @@
                               'views 0))
     (when (exists-binding? 'irc bs)
       (define nick (extract-binding/single 'nick bs))
-      (for ([c irc-channels])
-        (irc-send-message irc-connection c
-          (++ (if (string=? "" nick) "" (++ nick " pasted: "))
-              (if (string=? "" paste-name) "" (++ paste-name ", "))
-              paste-url))))
+      (irc-paste (++ (if (string=? "" nick) "" (++ nick " pasted: "))
+                     (if (string=? "" paste-name) "" (++ paste-name ", "))
+                     paste-url)))
     (fprintf log-port "~a\t~a\t~a\t~a\n"
              tm-str paste-num paste-name (request-client-ip request))
-    (response/xexpr
-     `(html ()
-        (head ()
-          (script () ,(++ "location.href=\"" paste-url "\"")))
-        (body ())))]
+    (redirect-to paste-url permanently)]
    [else
     (response/xexpr
      `(html ()
@@ -509,6 +552,42 @@
     (define code-main-div (get-main-div code-html))
     (define eval-main-div (get-main-div eval-html))
     (define paste-url (string-append paste-url-base pastenum))
+
+    ;; move-image-file: html -> html
+    ;; '(img ((alt "image") ,height (src ,filename) ,width))
+    ;;     =>
+    ;; '(img ((alt "image") ,height (src ,new-filename) ,width))
+    ;; side effect: moves pict file from tmp dir to permanent location in htdocs
+    (define (move-image-file filename height width
+                             [style '(style "")])
+      ;; rename file to avoid future clashes
+      (define rxmatch
+        (regexp-match #px"^(pict|\\d+)\\_*(\\d+)*\\.png"
+                      filename))
+      (unless rxmatch
+        (error "scribble made non-pict.png ~a" filename))
+      (match-define (list _ base offset) rxmatch)
+      (define new-file
+        (++ pastenum (if offset (++ "_" offset) "") ".png"))
+      (define curr-file-path
+        (build-path tmp-dir pastenum filename))
+      (define new-file-path
+        (build-path htdocs-dir new-file))
+      (unless (file-exists? new-file-path)
+        (copy-file curr-file-path new-file-path)
+        (delete-file curr-file-path))
+      `(img ((alt "image")
+         ,height (src ,(++ pastebin-url new-file)) ,style ,width)))
+    ;; should be a flat list of elems, even for nested lists
+    (define (move-image-files lst)
+      (for/list ([elem lst])
+        (match elem
+          ;; 611 added a "style" field
+          [`(img ((alt "image") ,height (src ,filename) ,style ,width))
+           (move-image-file filename height width style)]
+          [`(img ((alt "image") ,height (src ,filename) ,width))
+           (move-image-file filename height width)]
+          [x x])))
     (define main-html
       (match code-main-div
            [`(div ((class "main")) ,ver
@@ -539,7 +618,7 @@
                                                    "word-wrap:break-word")]) .
                   ,(filter
                     identity
-                    (map
+                    (map ; either rewrites html or produces #f to be filtered
                     (lambda (x)
                       (match x
                         ;; single-line evaled expr (with ">" prompt), skip
@@ -553,29 +632,30 @@
                                          . ,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)))))
-                         ;; rename file to avoid future clashes
-                         (define rxmatch
-                           (regexp-match #px"^(pict|\\d+)\\_*(\\d+)*\\.png"
-                                         filename))
-                         (unless rxmatch
-                           (error "scribble made non-pict.png ~a" filename))
-                         (match-define (list _ base offset) rxmatch)
-                         (define new-file
-                           (++ pastenum (if offset (++ "_" offset) "") ".png"))
-                         (define curr-file-path
-                           (build-path tmp-dir pastenum filename))
-                         (define new-file-path
-                           (build-path htdocs-dir new-file))
-                         (unless (file-exists? new-file-path)
-                           (copy-file curr-file-path new-file-path)
-                           (delete-file curr-file-path))
-                         `(tr () (td () (p () (img
-                            ((alt "image") ,height
-                             (src ,(++ pastebin-url new-file)) ,width)))))]
+                        ;; rewrite filename in image link (1st case):
+                        ;; html of img output (for pict) has changed (in 611?)
+                        ;; new "style" field added, so handle as separate case
+                        [`(tr () (td () (p ()
+                            (img ((alt "image")
+                              ,height (src ,filename) ,style ,width)))))
+                         ;; renames file to avoid future clashes
+                         ;; and rewrites html with new filename
+                         `(tr () (td () (p ()
+                           ,(move-image-file filename height width style))))]
+                        ;; fix filename in image link (2nd case)
+                        ;; (this was the only case before 611)
+                        [`(tr () (td () (p ()
+                            (img ((alt "image") ,height (src ,filename) ,width)))))
+                         ;; renames file to avoid future clashes
+                         ;; and rewrites html with new filename
+                         `(tr () (td () (p ()
+                           ,(move-image-file filename height width))))]
+                        ;; list(s) of images
+                        [`(tr () (td () (p ()
+                            (span ((class "RktRes")) "'(") . ,rst)))
+                         `(tr () (td () (p ()
+                            (span ((class "RktRes")) "'(")
+                            ,@(move-image-files rst))))]
                         ;; nested table
                         [`(tr () (td () (table ,attrs . ,rows)))
                          `(tr () (td () (table ([style ,(~~ "font-size:95%"
@@ -666,11 +746,13 @@
                  (table ((style "margin-top:-15px;font-size:95%"))
                         ,@test-cases-htmls))))))
 
+(require "plt-bacon.rkt")
 (define-values (do-dispatch mk-url)
   (dispatch-rules
    [("") serve-home]
    [("pastes" (string-arg)) serve-paste]
    [("tests") serve-tests]
+   [("bacon") serve-bacon]
    #;[else serve-home]))
 
 

plt-bacon.rkt

@@ -0,0 +1,196 @@
+#lang racket
+(require 
+  web-server/servlet web-server/servlet-env
+  web-server/formlets web-server/formlets/servlet
+  net/url
+  graph)
+
+;; scrape data ----------------------------------------------------------------
+(define PLT-PUBS-URL (string->url "http://www.ccs.neu.edu/racket/pubs/"))
+(define neu-pubs-port (get-pure-port PLT-PUBS-URL))
+;(define neu-pubs-port (open-input-file "plt-pubs.html"))
+
+(define name-pat "([A-Z][a-z\\-]+\\s?)+")
+(define word-pat "([A-Za-z\\-]+\\s?)+")
+(define names-pat (string-append "(" name-pat ",\\s)+" name-pat))
+(define title-pat (string-append "(?<=<cite>)\\s+(" word-pat ")+"))
+(define authors-px 
+  (pregexp 
+   (string-append "(?<=:|<div>)\\s*" names-pat ".+?" title-pat)))
+
+(define matches (regexp-match* authors-px neu-pubs-port))
+
+;; authors+title : [Listof author-string ... title-string]
+(define authors+title
+  (for/list ([authors matches])
+    (define as+title 
+      (string-split (string-trim (bytes->string/utf-8 authors)) #px",\\s+"))
+    (define last-auth+title 
+      (car (reverse as+title)))
+    (define first-authors 
+      (reverse (cdr (reverse as+title))))
+    (define last-auth+title-match 
+      (regexp-split #px"\\s+<br />|\\s+<cite>" last-auth+title))
+    (define as+t
+      (append first-authors 
+              (list (first last-auth+title-match)
+                    (string-trim (car (reverse last-auth+title-match))))))
+    as+t))
+
+;; populate graph -------------------------------------------------------------
+(define PLT-GRAPH (unweighted-graph/undirected null))
+(define-edge-property PLT-GRAPH papers)
+
+(for ([as+t authors+title])
+  (define authors (cdr (reverse as+t)))
+  (define title (car (reverse as+t)))
+  (for* ([auth1 authors]
+         [auth2 authors]
+         #:unless (string=? auth1 auth2))
+    (define papers-curr (papers auth1 auth2 #:default null))
+    (add-edge! PLT-GRAPH auth1 auth2)
+    (papers-set! auth1 auth2 (cons title papers-curr))))
+
+;; print to stdout ------------------------------------------------------------
+#;(define (plt-bacon auth erdos bacon)
+  (define erdos-path (fewest-vertices-path PLT-GRAPH auth erdos))
+  (define bacon-path (fewest-vertices-path PLT-GRAPH auth bacon))
+  ;; print erdos path
+  (for ([a1 erdos-path]
+        [a2 (cdr erdos-path)])
+    (printf "~a co-authored with ~a:\n" a1 a2)
+    (for ([p (papers a1 a2)])
+      (printf "  ~a\n" p)))
+  (define erdos-num (sub1 (length erdos-path)))
+  (printf "\n** ~a's ~a-number is: ~a\n\n" auth erdos erdos-num)
+  ;; print bacon path
+  (for ([a1 bacon-path]
+        [a2 (cdr bacon-path)])
+    (printf "~a co-authored with ~a:\n" a1 a2)
+    (for ([p (papers a1 a2)])
+      (printf "  ~a\n" p)))
+  (define bacon-num (sub1 (length bacon-path)))
+  (printf "\n** ~a's ~a-number is: ~a\n\n" auth bacon bacon-num)
+  (printf "## ~a's ~a-~a-number is: ~a\n"
+          auth erdos bacon
+          (+ erdos-num bacon-num)))
+  
+;; html output ----------------------------------------------------------------
+(define (plt-bacon-html auth erdos bacon)
+  (define erdos-path (fewest-vertices-path PLT-GRAPH auth erdos))
+  (define bacon-path (fewest-vertices-path PLT-GRAPH auth bacon))
+  (define erdos-num (sub1 (length erdos-path)))
+  (define bacon-num (sub1 (length bacon-path)))
+  `(table
+    (tr "Computed "
+        (i ,auth)
+        "'s "
+        (b ,erdos) "-" (b ,bacon) " number:")
+    (tr (br) (hr))
+    (tr
+     ;; print erdos path
+     ,@(for/list ([a1 erdos-path]
+                  [a2 (cdr erdos-path)])
+         `(table (tr (i ,(format "~a" a1))
+                     " co-authored with "
+                     (i ,(format "~a" a2))
+                     ":")
+                 (tr (ul
+                 ,@(for/list ([p (papers a1 a2)])
+                     `(li ,(format "~a" p))))))))
+    (tr "** "
+        (i ,(format "~a" auth))
+        "'s "
+        (b ,(format "~a" erdos))
+        "-number is: "
+        (b ,(format "~a" erdos-num)))
+    (tr (br) (hr))
+    (tr (br))
+    (tr
+    ;  ;; print bacon path
+    ,@(for/list ([a1 bacon-path]
+                 [a2 (cdr bacon-path)])
+         `(table (tr (i ,(format "~a" a1))
+                     " co-authored with "
+                     (i ,(format "~a" a2))
+                     ":")
+                (tr (ul
+                     ,@(for/list ([p (papers a1 a2)])
+                         `(li ,(format "~a" p))))))))
+    (tr "** "
+        (i ,(format "~a" auth))
+        "'s "
+        (b ,(format "~a" bacon))
+        "-number is: "
+        (b ,(format "~a" bacon-num)))
+    (tr (br) (hr))
+    (tr (br))
+    (tr
+        "## "
+        (i ,(format "~a" auth))
+        "'s "
+        (b ,(format "~a-~a" erdos bacon))
+        "-number is: "
+        (b ,(format "~a" (+ erdos-num bacon-num))))
+    (tr (br) (hr))))
+
+;;-----------------------------------------------------------------------------
+;; web server front end
+
+(define author-choices 
+  (sort
+   (filter-not 
+    (λ (v) (regexp-match #px"and\\s|b>|Felleisen\\." v))
+    (get-vertices PLT-GRAPH))
+   string<?))
+(define author-formlet
+  (formlet*
+   `(div
+     (div "Author Name: "
+          ,{(select-input
+             author-choices
+             #:selected? (lambda (x) (string=? x "Chang")))
+            . =>* . author})
+     (div "\"Bacon\": "
+          ,{(select-input
+             author-choices
+             #:selected? (lambda (x) (string=? x "Felleisen")))
+            . =>* . bacon})
+     (div "\"Erdos\": "
+          ,{(select-input
+             author-choices
+             #:selected? (lambda (x) (string=? x "Flatt")))
+            . =>* . erdos})
+     (div ,{(submit "Compute!") . =>* . res}))
+   ;(list author erdos bacon)))
+   ;; Q: Why is author etc a list?
+   (let ([response-gen
+          (λ (embed/url)
+            (response/xexpr
+             `(html
+               (title "Results")
+               (body (h1 "Results")
+                     (div ,(plt-bacon-html (car author) (car bacon) (car erdos)))
+                     (br) (br)
+                     (a ([href ,(embed/url serve-bacon)]) "Start Again")))))])
+     (send/suspend/dispatch response-gen))))
+   
+;(define (start request) (serve-bacon request))
+
+(provide serve-bacon)
+(define (serve-bacon request)
+  (define (response-generator embed/url)
+    (response/xexpr
+     `(html
+       (head (title "PLT Bacon"))
+       (body (h1 "PLT Bacon")
+             (img ([src "plt-bacon.png"]))
+             ,(embed-formlet embed/url author-formlet)))))
+  (send/suspend/dispatch response-generator))
+
+
+#;(serve/servlet start
+               #:launch-browser? #t
+               #:quit? #f
+               #:listen-ip #f
+               #:port 8000)

spam.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+
+;; Rudimentary spam detection
+
+(require racket/contract
+         racket/port
+         memoize
+         net/http-client
+         xml
+         xml/path)
+
+(provide (contract-out [check-ip (-> string? any)]))
+
+(define blacklist-host "api.stopforumspam.org")
+
+;; Returns #f if the lookup failed, if the response is malformed, or
+;; if the IP doesn't appear. Return #t if the IP does appear.
+;;
+;; The result is memoized to avoid querying the server too often.
+(define/memo (check-ip ip)
+  (define-values (status headers contents)
+    (http-sendrecv blacklist-host
+                   (format "/api?ip=~a" ip)))
+  (cond ;; only accept 200 OK
+        [(regexp-match #"200 OK" status)
+         (define response
+           (string->xexpr (port->string contents)))
+         (and response
+              (equal? "yes" (se-path* '(response appears) response)))]
+        [else #f]))