├── .gitignore ├── README.md ├── clean-tmp.rkt ├── filter-pastes.rkt ├── htdocs ├── codemirror.css ├── codemirror.js ├── neat.css ├── plt-back.1024x768.png ├── plt-bacon.png ├── racket.css ├── scribble-common.js ├── scribble-style.css ├── scribble.css └── submit.png ├── info.rkt ├── irc-bot.rkt ├── pasterack-parsing-utils.rkt ├── pasterack-test-cases.rkt ├── pasterack-utils.rkt ├── pasterack.rkt ├── plt-bacon.rkt └── spam.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | htdocs/* 2 | compiled/ 3 | *~ -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | pasterack 2 | ========= 3 | 4 | An evaluating [pastebin](http://www.pasterack.org) for Racket. 5 | 6 | pkg dependencies: ring-buffer, redis, irc, memoize, graph, lang-file 7 | -------------------------------------------------------------------------------- /clean-tmp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require redis) 3 | 4 | ; delete tmp file that dont have existing paste 5 | (define (clean-tmp tmp-dir htdoc-dir #:trial? [trial? #t]) 6 | (define dir-count 0) 7 | (define file-count 0) 8 | (when trial? (displayln "(trial mode)")) 9 | ;; 1) dirs in tmp 10 | (for ([d (in-directory tmp-dir (lambda go-into-dirs? #f))] 11 | #:when (directory-exists? d)) ; dirs only for now 12 | (define paste-num 13 | (substring (path->string d) (add1 (string-length tmp-dir)))) 14 | (unless (HEXISTS paste-num 'code) 15 | (printf "deleting tmp dir for paste ~a\n" paste-num) 16 | (set! dir-count (add1 dir-count)) 17 | (unless trial? (delete-directory/files d)))) 18 | ;; 2) files in tmp 19 | (for ([f (in-directory tmp-dir (lambda go-into-dirs? #f))] 20 | #:unless (directory-exists? f) 21 | #:when (regexp-match #px"/([0-9]+)" f)) 22 | (define paste-num 23 | (cadr (regexp-match #px"/([0-9]+)" f))) 24 | (unless (HEXISTS paste-num 'code) 25 | (printf "deleting file ~a\n" f) 26 | (set! file-count (add1 file-count)) 27 | (unless trial? (delete-file f)))) 28 | ;; 3) files in ht-docs 29 | (for ([f (in-directory htdoc-dir)] 30 | #:when (and (equal? #".png" (path-get-extension f)) 31 | (regexp-match #px"/([0-9]+)" f))) 32 | (define paste-num 33 | (cadr (regexp-match #px"/([0-9]+)" f))) 34 | (unless (HEXISTS paste-num 'code) 35 | (printf "deleting file ~a\n" f) 36 | (set! file-count (add1 file-count)) 37 | (unless trial? (delete-file f)))) 38 | (printf "Deleted ~a dirs\n" dir-count) 39 | (printf "Deleted ~a files\n" file-count)) 40 | 41 | 42 | (module+ main 43 | (define trial-mode (make-parameter #t)) 44 | (define tmp-dirs 45 | (command-line 46 | #:once-each 47 | [("--delete") "Do the deletions (default is trial mode)" (trial-mode #f)] 48 | #:args args 49 | (if (null? args) (list "tmp" "htdocs") args))) 50 | (apply clean-tmp tmp-dirs #:trial? (trial-mode))) 51 | -------------------------------------------------------------------------------- /filter-pastes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require redis) 3 | (require "banned.rkt") 4 | (provide contains-banned? contains-pat?) 5 | 6 | ;; delete all non-hash vals (ie, not pastes) 7 | (define (delete-nonpastes #:trial? [trial? #f]) 8 | (for ([k (KEYS "*")]) 9 | ; delete non-hashes 10 | (unless (string=? (TYPE k) "hash") 11 | (printf "deleting non-hash key: ~a\n" k) 12 | (unless trial? (DEL k))) 13 | ; delete hashes that are not pastes 14 | (unless (HEXISTS k 'code) 15 | (printf "deleting non-paste hash key: ~a\n" k) 16 | (unless trial? (DEL k))))) 17 | 18 | (define (contains-banned? str) 19 | (for/or ([p default-pats]) 20 | (contains-pat? p str))) 21 | (define (contains-pat? pat str) 22 | (define ci-pat (pregexp (string-append "(?i:" pat ")"))) 23 | (regexp-match ci-pat str)) 24 | 25 | ; deletes pastes satisfying the given regexp pattern 26 | (define (delete-pastes/pat pat #:trial? [trial? #f]) 27 | (define count 0) 28 | (printf "searching for pastes with pattern: ~a" pat) 29 | (when trial? (printf " (trial)")) 30 | (printf "\n") 31 | (for ([k (KEYS "*")]) 32 | (when (and (string=? (TYPE k) "hash") (HEXISTS k 'code)) ; valid paste 33 | (define paste-contents (HGET/str k 'code)) 34 | (define paste-name (HGET/str k 'name)) 35 | (define paste-dir (build-path "tmp" (bytes->path k))) 36 | (when (or (contains-pat? pat paste-contents) 37 | (contains-pat? pat paste-name)) 38 | (printf "deleting paste: ~a\n" k) 39 | (when (directory-exists? paste-dir) 40 | (printf "... and deleting directory: ~a\n" paste-dir)) 41 | (unless trial? 42 | ;; log the deletion 43 | (with-output-to-file (build-path "deleted-pastes" (bytes->path k)) 44 | (lambda () 45 | (printf "time: ~a\n" (HGET/str k 'time)) 46 | (printf "name: ~a\n" (HGET/str k 'name)) 47 | (printf "num: ~a\n" k) 48 | (printf "~a\n" paste-contents))) 49 | ;; do the deletion 50 | (DEL k) 51 | (when (directory-exists? paste-dir) 52 | (delete-directory/files paste-dir))) 53 | (set! count (add1 count))))) 54 | (printf "deleted ~a pastes matching pattern ~a\n" count pat)) 55 | 56 | (module+ main 57 | (define trial-mode (make-parameter #t)) 58 | (define pats 59 | (command-line 60 | #:once-each 61 | [("--delete") "Do the deletions (default is trial mode)" 62 | (trial-mode #f)] 63 | #:args args 64 | (if (null? args) default-pats args))) 65 | (for ([p pats]) 66 | (delete-pastes/pat p #:trial? (trial-mode)))) 67 | -------------------------------------------------------------------------------- /htdocs/codemirror.css: -------------------------------------------------------------------------------- 1 | /* BASICS */ 2 | 3 | .CodeMirror { 4 | /* Set height, width, borders, and global font properties here */ 5 | font-family: monospace; 6 | height: 300px; 7 | color: black; 8 | } 9 | 10 | /* PADDING */ 11 | 12 | .CodeMirror-lines { 13 | padding: 4px 0; /* Vertical padding around content */ 14 | } 15 | .CodeMirror pre { 16 | padding: 0 4px; /* Horizontal padding of content */ 17 | } 18 | 19 | .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler { 20 | background-color: white; /* The little square between H and V scrollbars */ 21 | } 22 | 23 | /* GUTTER */ 24 | 25 | .CodeMirror-gutters { 26 | border-right: 1px solid #ddd; 27 | background-color: #f7f7f7; 28 | white-space: nowrap; 29 | } 30 | .CodeMirror-linenumbers {} 31 | .CodeMirror-linenumber { 32 | padding: 0 3px 0 5px; 33 | min-width: 20px; 34 | text-align: right; 35 | color: #999; 36 | white-space: nowrap; 37 | } 38 | 39 | .CodeMirror-guttermarker { color: black; } 40 | .CodeMirror-guttermarker-subtle { color: #999; } 41 | 42 | /* CURSOR */ 43 | 44 | .CodeMirror-cursor { 45 | border-left: 1px solid black; 46 | border-right: none; 47 | width: 0; 48 | } 49 | /* Shown when moving in bi-directional text */ 50 | .CodeMirror div.CodeMirror-secondarycursor { 51 | border-left: 1px solid silver; 52 | } 53 | .cm-fat-cursor .CodeMirror-cursor { 54 | width: auto; 55 | border: 0; 56 | background: #7e7; 57 | } 58 | .cm-fat-cursor div.CodeMirror-cursors { 59 | z-index: 1; 60 | } 61 | 62 | .cm-animate-fat-cursor { 63 | width: auto; 64 | border: 0; 65 | -webkit-animation: blink 1.06s steps(1) infinite; 66 | -moz-animation: blink 1.06s steps(1) infinite; 67 | animation: blink 1.06s steps(1) infinite; 68 | background-color: #7e7; 69 | } 70 | @-moz-keyframes blink { 71 | 0% {} 72 | 50% { background-color: transparent; } 73 | 100% {} 74 | } 75 | @-webkit-keyframes blink { 76 | 0% {} 77 | 50% { background-color: transparent; } 78 | 100% {} 79 | } 80 | @keyframes blink { 81 | 0% {} 82 | 50% { background-color: transparent; } 83 | 100% {} 84 | } 85 | 86 | /* Can style cursor different in overwrite (non-insert) mode */ 87 | .CodeMirror-overwrite .CodeMirror-cursor {} 88 | 89 | .cm-tab { display: inline-block; text-decoration: inherit; } 90 | 91 | .CodeMirror-ruler { 92 | border-left: 1px solid #ccc; 93 | position: absolute; 94 | } 95 | 96 | /* DEFAULT THEME */ 97 | 98 | .cm-s-default .cm-header {color: blue;} 99 | .cm-s-default .cm-quote {color: #090;} 100 | .cm-negative {color: #d44;} 101 | .cm-positive {color: #292;} 102 | .cm-header, .cm-strong {font-weight: bold;} 103 | .cm-em {font-style: italic;} 104 | .cm-link {text-decoration: underline;} 105 | .cm-strikethrough {text-decoration: line-through;} 106 | 107 | .cm-s-default .cm-keyword {color: #708;} 108 | .cm-s-default .cm-atom {color: #219;} 109 | .cm-s-default .cm-number {color: #164;} 110 | .cm-s-default .cm-def {color: #00f;} 111 | .cm-s-default .cm-variable, 112 | .cm-s-default .cm-punctuation, 113 | .cm-s-default .cm-property, 114 | .cm-s-default .cm-operator {} 115 | .cm-s-default .cm-variable-2 {color: #05a;} 116 | .cm-s-default .cm-variable-3 {color: #085;} 117 | .cm-s-default .cm-comment {color: #a50;} 118 | .cm-s-default .cm-string {color: #a11;} 119 | .cm-s-default .cm-string-2 {color: #f50;} 120 | .cm-s-default .cm-meta {color: #555;} 121 | .cm-s-default .cm-qualifier {color: #555;} 122 | .cm-s-default .cm-builtin {color: #30a;} 123 | .cm-s-default .cm-bracket {color: #997;} 124 | .cm-s-default .cm-tag {color: #170;} 125 | .cm-s-default .cm-attribute {color: #00c;} 126 | .cm-s-default .cm-hr {color: #999;} 127 | .cm-s-default .cm-link {color: #00c;} 128 | 129 | .cm-s-default .cm-error {color: #f00;} 130 | .cm-invalidchar {color: #f00;} 131 | 132 | .CodeMirror-composing { border-bottom: 2px solid; } 133 | 134 | /* Default styles for common addons */ 135 | 136 | div.CodeMirror span.CodeMirror-matchingbracket {color: #0f0;} 137 | div.CodeMirror span.CodeMirror-nonmatchingbracket {color: #f22;} 138 | .CodeMirror-matchingtag { background: rgba(255, 150, 0, .3); } 139 | .CodeMirror-activeline-background {background: #e8f2ff;} 140 | 141 | /* STOP */ 142 | 143 | /* The rest of this file contains styles related to the mechanics of 144 | the editor. You probably shouldn't touch them. */ 145 | 146 | .CodeMirror { 147 | position: relative; 148 | overflow: hidden; 149 | background: white; 150 | } 151 | 152 | .CodeMirror-scroll { 153 | overflow: scroll !important; /* Things will break if this is overridden */ 154 | /* 30px is the magic margin used to hide the element's real scrollbars */ 155 | /* See overflow: hidden in .CodeMirror */ 156 | margin-bottom: -30px; margin-right: -30px; 157 | padding-bottom: 30px; 158 | height: 100%; 159 | outline: none; /* Prevent dragging from highlighting the element */ 160 | position: relative; 161 | } 162 | .CodeMirror-sizer { 163 | position: relative; 164 | border-right: 30px solid transparent; 165 | } 166 | 167 | /* The fake, visible scrollbars. Used to force redraw during scrolling 168 | before actuall scrolling happens, thus preventing shaking and 169 | flickering artifacts. */ 170 | .CodeMirror-vscrollbar, .CodeMirror-hscrollbar, .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler { 171 | position: absolute; 172 | z-index: 6; 173 | display: none; 174 | } 175 | .CodeMirror-vscrollbar { 176 | right: 0; top: 0; 177 | overflow-x: hidden; 178 | overflow-y: scroll; 179 | } 180 | .CodeMirror-hscrollbar { 181 | bottom: 0; left: 0; 182 | overflow-y: hidden; 183 | overflow-x: scroll; 184 | } 185 | .CodeMirror-scrollbar-filler { 186 | right: 0; bottom: 0; 187 | } 188 | .CodeMirror-gutter-filler { 189 | left: 0; bottom: 0; 190 | } 191 | 192 | .CodeMirror-gutters { 193 | position: absolute; left: 0; top: 0; 194 | z-index: 3; 195 | } 196 | .CodeMirror-gutter { 197 | white-space: normal; 198 | height: 100%; 199 | display: inline-block; 200 | margin-bottom: -30px; 201 | /* Hack to make IE7 behave */ 202 | *zoom:1; 203 | *display:inline; 204 | } 205 | .CodeMirror-gutter-wrapper { 206 | position: absolute; 207 | z-index: 4; 208 | background: none !important; 209 | border: none !important; 210 | } 211 | .CodeMirror-gutter-background { 212 | position: absolute; 213 | top: 0; bottom: 0; 214 | z-index: 4; 215 | } 216 | .CodeMirror-gutter-elt { 217 | position: absolute; 218 | cursor: default; 219 | z-index: 4; 220 | } 221 | .CodeMirror-gutter-wrapper { 222 | -webkit-user-select: none; 223 | -moz-user-select: none; 224 | user-select: none; 225 | } 226 | 227 | .CodeMirror-lines { 228 | cursor: text; 229 | min-height: 1px; /* prevents collapsing before first draw */ 230 | } 231 | .CodeMirror pre { 232 | /* Reset some styles that the rest of the page might have set */ 233 | -moz-border-radius: 0; -webkit-border-radius: 0; border-radius: 0; 234 | border-width: 0; 235 | background: transparent; 236 | font-family: inherit; 237 | font-size: inherit; 238 | margin: 0; 239 | white-space: pre; 240 | word-wrap: normal; 241 | line-height: inherit; 242 | color: inherit; 243 | z-index: 2; 244 | position: relative; 245 | overflow: visible; 246 | -webkit-tap-highlight-color: transparent; 247 | } 248 | .CodeMirror-wrap pre { 249 | word-wrap: break-word; 250 | white-space: pre-wrap; 251 | word-break: normal; 252 | } 253 | 254 | .CodeMirror-linebackground { 255 | position: absolute; 256 | left: 0; right: 0; top: 0; bottom: 0; 257 | z-index: 0; 258 | } 259 | 260 | .CodeMirror-linewidget { 261 | position: relative; 262 | z-index: 2; 263 | overflow: auto; 264 | } 265 | 266 | .CodeMirror-widget {} 267 | 268 | .CodeMirror-code { 269 | outline: none; 270 | } 271 | 272 | /* Force content-box sizing for the elements where we expect it */ 273 | .CodeMirror-scroll, 274 | .CodeMirror-sizer, 275 | .CodeMirror-gutter, 276 | .CodeMirror-gutters, 277 | .CodeMirror-linenumber { 278 | -moz-box-sizing: content-box; 279 | box-sizing: content-box; 280 | } 281 | 282 | .CodeMirror-measure { 283 | position: absolute; 284 | width: 100%; 285 | height: 0; 286 | overflow: hidden; 287 | visibility: hidden; 288 | } 289 | 290 | .CodeMirror-cursor { position: absolute; } 291 | .CodeMirror-measure pre { position: static; } 292 | 293 | div.CodeMirror-cursors { 294 | visibility: hidden; 295 | position: relative; 296 | z-index: 3; 297 | } 298 | div.CodeMirror-dragcursors { 299 | visibility: visible; 300 | } 301 | 302 | .CodeMirror-focused div.CodeMirror-cursors { 303 | visibility: visible; 304 | } 305 | 306 | .CodeMirror-selected { background: #d9d9d9; } 307 | .CodeMirror-focused .CodeMirror-selected { background: #d7d4f0; } 308 | .CodeMirror-crosshair { cursor: crosshair; } 309 | .CodeMirror-line::selection, .CodeMirror-line > span::selection, .CodeMirror-line > span > span::selection { background: #d7d4f0; } 310 | .CodeMirror-line::-moz-selection, .CodeMirror-line > span::-moz-selection, .CodeMirror-line > span > span::-moz-selection { background: #d7d4f0; } 311 | 312 | .cm-searching { 313 | background: #ffa; 314 | background: rgba(255, 255, 0, .4); 315 | } 316 | 317 | /* IE7 hack to prevent it from returning funny offsetTops on the spans */ 318 | .CodeMirror span { *vertical-align: text-bottom; } 319 | 320 | /* Used to force a border model for a node */ 321 | .cm-force-border { padding-right: .1px; } 322 | 323 | @media print { 324 | /* Hide the cursor when printing */ 325 | .CodeMirror div.CodeMirror-cursors { 326 | visibility: hidden; 327 | } 328 | } 329 | 330 | /* See issue #2901 */ 331 | .cm-tab-wrap-hack:after { content: ''; } 332 | 333 | /* Help users use markselection to safely style text background */ 334 | span.CodeMirror-selectedtext { background: none; } 335 | -------------------------------------------------------------------------------- /htdocs/neat.css: -------------------------------------------------------------------------------- 1 | .cm-s-neat span.cm-comment { color: #a86; } 2 | .cm-s-neat span.cm-keyword { line-height: 1em; font-weight: bold; color: blue; } 3 | .cm-s-neat span.cm-string { color: #a22; } 4 | .cm-s-neat span.cm-builtin { line-height: 1em; font-weight: bold; color: #077; } 5 | .cm-s-neat span.cm-special { line-height: 1em; font-weight: bold; color: #0aa; } 6 | .cm-s-neat span.cm-variable { color: black; } 7 | .cm-s-neat span.cm-number, .cm-s-neat span.cm-atom { color: #3a3; } 8 | .cm-s-neat span.cm-meta { color: #555; } 9 | .cm-s-neat span.cm-link { color: #3a3; } 10 | 11 | .cm-s-neat .CodeMirror-activeline-background { background: #e8f2ff; } 12 | .cm-s-neat .CodeMirror-matchingbracket { outline:1px solid grey; color:black !important; } 13 | -------------------------------------------------------------------------------- /htdocs/plt-back.1024x768.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stchang/pasterack/1e4e2cc31e873044e76e329d42761363a9875fa2/htdocs/plt-back.1024x768.png -------------------------------------------------------------------------------- /htdocs/plt-bacon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stchang/pasterack/1e4e2cc31e873044e76e329d42761363a9875fa2/htdocs/plt-bacon.png -------------------------------------------------------------------------------- /htdocs/racket.css: -------------------------------------------------------------------------------- 1 | 2 | /* See the beginning of "scribble.css". */ 3 | 4 | /* Monospace: */ 5 | .RktIn, .RktRdr, .RktPn, .RktMeta, 6 | .RktMod, .RktKw, .RktVar, .RktSym, 7 | .RktRes, .RktOut, .RktCmt, .RktVal, 8 | .RktBlk { 9 | font-family: 'Droid Sans Mono',monospace; 10 | white-space: inherit; 11 | } 12 | 13 | /* Serif: */ 14 | .inheritedlbl { 15 | font-family: serif; 16 | } 17 | 18 | /* Sans-serif: */ 19 | .RBackgroundLabelInner { 20 | font-family: sans-serif; 21 | } 22 | 23 | /* ---------------------------------------- */ 24 | /* Inherited methods, left margin */ 25 | 26 | .inherited { 27 | width: 100%; 28 | margin-top: 0.5em; 29 | text-align: left; 30 | background-color: #ECF5F5; 31 | } 32 | 33 | .inherited td { 34 | font-size: 82%; 35 | padding-left: 1em; 36 | text-indent: -0.8em; 37 | padding-right: 0.2em; 38 | } 39 | 40 | .inheritedlbl { 41 | font-style: italic; 42 | } 43 | 44 | /* ---------------------------------------- */ 45 | /* Racket text styles */ 46 | 47 | .RktIn { 48 | color: #cc6633; 49 | background-color: #eeeeee; 50 | } 51 | 52 | .RktInBG { 53 | background-color: #eeeeee; 54 | } 55 | 56 | .RktRdr { 57 | } 58 | 59 | .RktPn { 60 | color: #843c24; 61 | } 62 | 63 | .RktMeta { 64 | color: black; 65 | } 66 | 67 | .RktMod { 68 | color: black; 69 | } 70 | 71 | .RktOpt { 72 | color: black; 73 | } 74 | 75 | .RktKw { 76 | color: black; 77 | /* font-weight: bold; */ 78 | } 79 | 80 | .RktErr { 81 | color: red; 82 | font-style: italic; 83 | } 84 | 85 | .RktVar { 86 | color: #262680; 87 | font-style: italic; 88 | } 89 | 90 | .RktSym { 91 | color: #262680; 92 | } 93 | 94 | .RktValLink { 95 | text-decoration: none; 96 | color: blue; 97 | } 98 | 99 | .RktModLink { 100 | text-decoration: none; 101 | color: blue; 102 | } 103 | 104 | .RktStxLink { 105 | text-decoration: none; 106 | color: black; 107 | /* font-weight: bold; */ 108 | } 109 | 110 | .RktRes { 111 | color: #0000af; 112 | } 113 | 114 | .RktOut { 115 | color: #960096; 116 | } 117 | 118 | .RktCmt { 119 | color: #c2741f; 120 | } 121 | 122 | .RktVal { 123 | color: #228b22; 124 | } 125 | 126 | /* ---------------------------------------- */ 127 | /* Some inline styles */ 128 | 129 | .together { 130 | width: 100%; 131 | } 132 | 133 | .prototype, .argcontract, .RBoxed { 134 | white-space: nowrap; 135 | } 136 | 137 | .prototype td { 138 | vertical-align: text-top; 139 | } 140 | .longprototype td { 141 | vertical-align: bottom; 142 | } 143 | 144 | .RktBlk { 145 | white-space: inherit; 146 | text-align: left; 147 | } 148 | 149 | .RktBlk tr { 150 | white-space: inherit; 151 | } 152 | 153 | .RktBlk td { 154 | vertical-align: baseline; 155 | white-space: inherit; 156 | } 157 | 158 | .argcontract td { 159 | vertical-align: text-top; 160 | } 161 | 162 | .highlighted { 163 | background-color: #ddddff; 164 | } 165 | 166 | .defmodule { 167 | width: 100%; 168 | background-color: #F5F5DC; 169 | } 170 | 171 | .specgrammar { 172 | float: right; 173 | } 174 | 175 | .RBibliography td { 176 | vertical-align: text-top; 177 | } 178 | 179 | .leftindent { 180 | margin-left: 1em; 181 | margin-right: 0em; 182 | } 183 | 184 | .insetpara { 185 | margin-left: 1em; 186 | margin-right: 1em; 187 | } 188 | 189 | .Rfilebox { 190 | } 191 | 192 | .Rfiletitle { 193 | text-align: right; 194 | margin: 0em 0em 0em 0em; 195 | } 196 | 197 | .Rfilename { 198 | border-top: 1px solid #6C8585; 199 | border-right: 1px solid #6C8585; 200 | padding-left: 0.5em; 201 | padding-right: 0.5em; 202 | background-color: #ECF5F5; 203 | } 204 | 205 | .Rfilecontent { 206 | margin: 0em 0em 0em 0em; 207 | } 208 | 209 | .RpackageSpec { 210 | padding-right: 0.5em; 211 | } 212 | 213 | /* ---------------------------------------- */ 214 | /* For background labels */ 215 | 216 | .RBackgroundLabel { 217 | float: right; 218 | width: 0px; 219 | height: 0px; 220 | } 221 | 222 | .RBackgroundLabelInner { 223 | position: relative; 224 | width: 25em; 225 | left: -25.5em; 226 | top: 0px; 227 | text-align: right; 228 | color: white; 229 | z-index: 0; 230 | font-weight: bold; 231 | } 232 | 233 | .RForeground { 234 | position: relative; 235 | left: 0px; 236 | top: 0px; 237 | z-index: 1; 238 | } 239 | -------------------------------------------------------------------------------- /htdocs/scribble-common.js: -------------------------------------------------------------------------------- 1 | // Common functionality for PLT documentation pages 2 | 3 | // Page Parameters ------------------------------------------------------------ 4 | 5 | var page_query_string = 6 | (location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1; 7 | 8 | var page_args = 9 | ((function(){ 10 | if (!page_query_string) return []; 11 | var args = page_query_string.split(/[&;]/); 12 | for (var i=0; i= 0) args[i] = [a.substring(0,p), a.substring(p+1)]; 16 | else args[i] = [a, false]; 17 | } 18 | return args; 19 | })()); 20 | 21 | function GetPageArg(key, def) { 22 | for (var i=0; i= 0 && cur.substring(0,eql) == key) 66 | return unescape(cur.substring(eql+1)); 67 | } 68 | return def; 69 | } 70 | 71 | function SetCookie(key, val) { 72 | var d = new Date(); 73 | d.setTime(d.getTime()+(365*24*60*60*1000)); 74 | try { 75 | document.cookie = 76 | key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/"; 77 | } catch (e) {} 78 | } 79 | 80 | // note that this always stores a directory name, ending with a "/" 81 | function SetPLTRoot(ver, relative) { 82 | var root = location.protocol + "//" + location.host 83 | + NormalizePath(location.pathname.replace(/[^\/]*$/, relative)); 84 | SetCookie("PLT_Root."+ver, root); 85 | } 86 | 87 | // adding index.html works because of the above 88 | function GotoPLTRoot(ver, relative) { 89 | var u = GetCookie("PLT_Root."+ver, null); 90 | if (u == null) return true; // no cookie: use plain up link 91 | // the relative path is optional, default goes to the toplevel start page 92 | if (!relative) relative = "index.html"; 93 | location = u + relative; 94 | return false; 95 | } 96 | 97 | // Utilities ------------------------------------------------------------------ 98 | 99 | var normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/]; 100 | function NormalizePath(path) { 101 | var tmp, i; 102 | for (i = 0; i < normalize_rxs.length; i++) 103 | while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp; 104 | return path; 105 | } 106 | 107 | // `noscript' is problematic in some browsers (always renders as a 108 | // block), use this hack instead (does not always work!) 109 | // document.write(""); 110 | 111 | // Interactions --------------------------------------------------------------- 112 | 113 | function DoSearchKey(event, field, ver, top_path) { 114 | var val = field.value; 115 | if (event && event.keyCode == 13) { 116 | var u = GetCookie("PLT_Root."+ver, null); 117 | if (u == null) u = top_path; // default: go to the top path 118 | u += "search/index.html?q=" + escape(val); 119 | if (page_query_string) u += "&" + page_query_string; 120 | location = u; 121 | return false; 122 | } 123 | return true; 124 | } 125 | 126 | function TocviewToggle(glyph, id) { 127 | var s = document.getElementById(id).style; 128 | var expand = s.display == "none"; 129 | s.display = expand ? "block" : "none"; 130 | glyph.innerHTML = expand ? "▼" : "►"; 131 | } 132 | 133 | // Page Init ------------------------------------------------------------------ 134 | 135 | // Note: could make a function that inspects and uses window.onload to chain to 136 | // a previous one, but this file needs to be required first anyway, since it 137 | // contains utilities for all other files. 138 | var on_load_funcs = []; 139 | function AddOnLoad(fun) { on_load_funcs.push(fun); } 140 | window.onload = function() { 141 | for (var i=0; i 406 | .techinside doesn't work with IE, so use both (and IE doesn't 407 | work with inherit in the second one, so use blue directly) */ 408 | .techinside { color: black; } 409 | .techinside:hover { color: blue; } 410 | .techoutside:hover>.techinside { color: inherit; } 411 | 412 | .SCentered { 413 | text-align: center; 414 | } 415 | 416 | .imageleft { 417 | float: left; 418 | margin-right: 0.3em; 419 | } 420 | 421 | .Smaller { 422 | font-size: 82%; 423 | background-color: transparent; 424 | } 425 | 426 | .Larger { 427 | font-size: 122%; 428 | } 429 | 430 | /* A hack, inserted to break some Scheme ids: */ 431 | .mywbr { 432 | width: 0; 433 | font-size: 1px; 434 | } 435 | 436 | .compact li p { 437 | margin: 0em; 438 | padding: 0em; 439 | } 440 | 441 | .noborder img { 442 | border: 0; 443 | } 444 | 445 | .SAuthorListBox { 446 | position: relative; 447 | float: right; 448 | left: 2em; 449 | top: -2.5em; 450 | height: 0em; 451 | width: 13em; 452 | margin: 0em -13em 0em 0em; 453 | } 454 | .SAuthorList { 455 | font-size: 82%; 456 | } 457 | .SAuthorList:before { 458 | content: "by "; 459 | } 460 | .author { 461 | display: inline; 462 | white-space: nowrap; 463 | } 464 | 465 | /* print styles : hide the navigation elements */ 466 | @media print { 467 | .tocset, 468 | .navsettop, 469 | .navsetbottom { display: none; } 470 | .maincolumn { 471 | width: auto; 472 | margin-right: 13em; 473 | margin-left: 0; 474 | } 475 | } 476 | -------------------------------------------------------------------------------- /htdocs/submit.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stchang/pasterack/1e4e2cc31e873044e76e329d42761363a9875fa2/htdocs/submit.png -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define deps '("ring-buffer" "irc" "redis" "memoize" "graph" "lang-file")) 4 | -------------------------------------------------------------------------------- /irc-bot.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require irc racket/async-channel) 3 | (provide pasterack-irc-connect irc-paste) 4 | 5 | ;; pasterack irc bot 6 | 7 | (define MIRROR? #f) 8 | 9 | (define FREENODE "chat.freenode.net") 10 | (define PORT 6667) 11 | (define NAME (if MIRROR? "pasteracktest" "pasterack")) 12 | 13 | 14 | (define irc-channels (if MIRROR? '("#racktest") '("#racket"))) 15 | 16 | (define current-irc-connection #f) 17 | (define current-irc-listener (thread void)) 18 | (define current-irc-monitor (thread void)) 19 | 20 | 21 | (define (irc-connect/internal) 22 | (define-values (irc-connection ready) 23 | (irc-connect FREENODE PORT NAME NAME NAME #:return-eof #t)) 24 | (define achan (irc-connection-incoming irc-connection)) 25 | (set! current-irc-connection irc-connection) 26 | (set! current-irc-listener 27 | (thread 28 | (lambda () 29 | (let loop () 30 | (unless (eof-object? (async-channel-get achan)) 31 | (loop)))))) 32 | ready) 33 | 34 | ;; creates an irc monitor thread 35 | (define (pasterack-irc-connect) 36 | (set! current-irc-monitor 37 | (thread 38 | (lambda () 39 | (let loop () 40 | (when (thread-dead? current-irc-listener) 41 | (sync (irc-connect/internal)) 42 | (join-channels)) 43 | (sleep 60) 44 | (loop)))))) 45 | 46 | (define (join-channels) 47 | (for ([c irc-channels]) (irc-join-channel current-irc-connection c))) 48 | 49 | (define (irc-paste msg) 50 | (for ([c irc-channels]) (irc-send-message current-irc-connection c msg))) 51 | 52 | -------------------------------------------------------------------------------- /pasterack-parsing-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require syntax/stx syntax/parse) 3 | (require "pasterack-utils.rkt") 4 | 5 | ;; parsing utility functions used by pasterack.org 6 | 7 | (provide (all-defined-out)) 8 | 9 | ;; lang regexp patterns 10 | (define hashlang-pat #px"^\\#lang ([\\w/\\-\\+]+)\\s*(.*)") 11 | (define weblang-pat #px"^web-server.*") 12 | (define scribblelang-pat #px"^scribble/.*") 13 | (define htdplang-pat #px"^lang/htdp-(.*)") 14 | (define TRlang-pat #px"^typed/racket.*") 15 | (define plai-pat #px"^plai.*") 16 | 17 | (define (hashlang? code) 18 | (define in (open-input-string code)) 19 | (begin0 (read-language in (lambda () #f)) (close-input-port in))) 20 | 21 | ;; Returns #t if str has "#lang" somewhere. 22 | (define (has-hashlang? str) 23 | (regexp-match "#lang" str)) 24 | 25 | ;; ie maps htdp/bsl -> lang/htdp-beginner 26 | (define (htdplang->modulename lang) 27 | (match (cadr (regexp-match htdplang-pat lang)) 28 | ["bsl" "lang/htdp-beginner"] 29 | ["bsl+" "lang/htdp-beginner-abbr"] 30 | ["isl" "lang/htdp-intermediate"] 31 | ["isl+" "lang/htdp-intermediate-lambda"] 32 | ["asl" "lang/htdp-advanced"] 33 | [_ "racket"])) 34 | 35 | ;; returns two string values, one for lang and one for the rest of the program 36 | (define (hashlang-split code) 37 | (match (regexp-match hashlang-pat code) 38 | [(list _ lang rst) (values lang rst)] 39 | [_ (values "racket" code)])) 40 | 41 | (define (scribble-lang? lang) (regexp-match scribblelang-pat lang)) 42 | (define (htdp-lang? lang) (regexp-match htdplang-pat lang)) 43 | (define (TR-lang? lang) (regexp-match TRlang-pat lang)) 44 | (define (web-lang? lang) (regexp-match weblang-pat lang)) 45 | (define (plai-lang? lang) (regexp-match plai-pat lang)) 46 | 47 | ;; htdp form patterns 48 | (define provide-pat #px"^\\(provide (.*)\\)$") 49 | (define require-pat #px"^\\(require (.*)\\)$") 50 | (define define-pat #px"^\\(define(.*)\\)$") 51 | (define check-pat #px"^\\(check-(.*)\\)$") 52 | 53 | (define (require-datum? e) (get-require-spec e)) 54 | (define (provide-datum? e) (regexp-match provide-pat (to-string/s e))) 55 | (define (define-datum? e) (regexp-match define-pat (to-string e))) 56 | (define (check-datum? e) (regexp-match check-pat (to-string e))) 57 | (define (get-require-spec e) (regexp-match require-pat (to-string/s e))) 58 | 59 | ;; for now, only accept certain forms 60 | ;; (ie reject strings) 61 | (define (valid-req? r) 62 | (or (symbol? r) 63 | (and (pair? r) 64 | (let ([form (car r)]) 65 | (define (symeq? x) (eq? x form)) 66 | (or 67 | (and (ormap symeq? '(only-in except-in rename-in)) 68 | (valid-req? (second r))) 69 | (and (ormap symeq? '(prefix-in)) 70 | (valid-req? (third r))) 71 | (and (ormap symeq? '(combine-in)) 72 | (andmap valid-req? (cdr r)))))))) 73 | 74 | (define (not-htdp-expr? e) (or (require-datum? e) (provide-datum? e) 75 | (check-datum? e) (define-datum? e))) 76 | 77 | ;; wont work if s has a #lang line 78 | ;; returns list of datums 79 | (define (string->datums s) 80 | (with-handlers ([exn:fail? (lambda () null)]) 81 | (with-input-from-string s (lambda () (for/list ([e (in-port)]) e))))) 82 | 83 | ;; stx predicates 84 | (define (not-expr? d [out (current-output-port)]) 85 | (with-handlers ([exn:fail:syntax? (lambda (e) (displayln (exn-message e)) #t)]) 86 | (define expanded (expand-to-top-form d)) 87 | (define hd (and (stx-pair? expanded) 88 | ;; not identifier always means %#app, %#datum, or %#top (?) 89 | ;; ie, an expression? 90 | (identifier? (stx-car expanded)) 91 | (stx-car expanded))) 92 | ;; (fprintf out "expanded: ~a\n" (syntax->datum expanded)) 93 | ;; (fprintf out "hd: ~a\n" hd) 94 | (and hd 95 | ;; check for begin 96 | (or (and (free-identifier=? hd #'begin) 97 | (for/and ([s (stx->list (stx-cdr (expand d)))]) 98 | (not-expr? s out))) 99 | (and 100 | ;; (when (or (free-identifier=? hd #'define-syntaxes) 101 | ;; (free-identifier=? hd #'begin-for-syntax) 102 | ;; (free-identifier=? hd #'#%require)) 103 | ;; (eval d)) 104 | (for/or ([form 105 | (syntax->list 106 | ;; ok to do define-values from interactions prompt 107 | ;; (but set! must be classified same as define-values) 108 | #'(module module* begin-for-syntax 109 | #%provide #%require define-syntaxes))]) 110 | (free-identifier=? hd form))))))) 111 | 112 | ;; stx utils 113 | (define (get-module-lang stx) 114 | (syntax-parse stx #:datum-literals (module) 115 | [(module _:id lang . mod-beg) 116 | #'lang] 117 | [_ #'racket])) 118 | (define (require-stx? stx) 119 | (syntax-parse stx #:datum-literals (require) 120 | [(require . _) #t] 121 | [_ #f])) 122 | ;; get-module-reqs : Syntax -> (List Syntax) 123 | (define (get-module-reqs stx) 124 | (append* 125 | (for/list ([e (get-module-bodys stx)] #:when (require-stx? e)) 126 | (stx->list (stx-cdr e))))) 127 | 128 | ;; get-module-bodys : Syntax -> (List Syntax) 129 | (define (get-module-bodys stx) 130 | (syntax-parse stx 131 | [(_ name:id lang (mod-beg body ...)) 132 | (stx->list #'(body ...))] 133 | [_ empty])) 134 | 135 | ;; copied from AlexKnauth lang-file pkg (unprovided fns) 136 | 137 | ;; private value eq? to itself 138 | (define read-language-fail (gensym 'read-language-fail)) 139 | (define (read-language-fail? v) 140 | (eq? v read-language-fail)) 141 | ;; read-lang : Input-Port -> (U False String) 142 | (define (read-lang port) 143 | (port-count-lines! port) 144 | (define port* (peeking-input-port port)) 145 | (port-count-lines! port*) 146 | (and 147 | (with-handlers ([exn:fail:read? (λ (e) #false)]) 148 | (not (read-language-fail? (read-language port* (λ () read-language-fail))))) 149 | (let* ([end (file-position port*)] 150 | [str (read-string end port)] 151 | [hash-lang-positions (regexp-match-positions* "#lang|#!" str)] 152 | [start (cdr (last hash-lang-positions))]) 153 | (string-trim (substring str start))))) 154 | -------------------------------------------------------------------------------- /pasterack-test-cases.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; test cases for pasterack.org 3 | (provide (all-defined-out)) 4 | 5 | (define test-cases 6 | '( 7 | ;; require tests 8 | ; "7262" ; html-render ; deleted for some reason 9 | "5751" ; only-in 10 | "9993" ; except-in 11 | "8521" ; prefix-in 12 | "6777" ; rename-in 13 | "4580" ; combine-in 14 | ;; proper doc linking 15 | "2425" ; 2htdp/image image? doc link 16 | "3233" ; htdp/bsl image? doc link 17 | "6998" ; matrix mult (example of require id, perm, that's also in #lang) 18 | ;; path permissions 19 | "7449" ; delete file 20 | "4749" ; list root 21 | "8953" ; Sierpinski 22 | "60761" ; Sierpinski in ASL using recur 23 | "5563" ; Greek letters 24 | "4837" ; lazy fib 25 | "28685" ; set bang (test multi-expr) 26 | "3259" ; scribble syntax 27 | "5238" ; big bang (test 2 requires on 1 line) 28 | "3883" ; echo serv, test limits, and forms in racket but not racket/base 29 | "7658" ; typed/racket -- also example of begin in top-context 30 | "9269" ; type error 31 | "2277" ; checkerboard (slideshow/pict) 32 | "4786" ; #lang htdp/bsl + 2htdp/image 33 | "8314" ; check-expect 34 | "9979" ; check-expect pass 35 | "96501" ; plot -- also example of begin that should be expression 36 | "7489" ; bad syntax 37 | "10731" ; missing #lang 38 | "79212" ; macro-generated set! 39 | "4734" ; quibble (module+) 40 | "5114" ; out of order macros 41 | "8757" ; out of order defines 42 | "5795" ; #lang blank 43 | "4662" ; blank 44 | "4126" ; nested list of images 45 | "5791" ; list of images (thanks jrslepak) 46 | "5568" ; plai 47 | "29314"; fish pict 48 | "12143" ; comment before #lang 49 | "70309" ; s-exp comment before #lang 50 | "4683" ; explicit reader 51 | "32200" ; at-exp 52 | "58952" ; 2d 53 | "11302" ; issue #61 stx->list 54 | ;; BROKEN: submodule evaluation 55 | )) 56 | -------------------------------------------------------------------------------- /pasterack-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/date racket/match) 3 | (provide (all-defined-out)) 4 | 5 | (define o compose) 6 | (define ++ string-append) 7 | (define (to-string d) (format "~a" d)) 8 | (define (to-string/v d) (format "~v" d)) 9 | (define (to-string/s d) (format "~s" d)) 10 | 11 | (define (mk-rand-str) 12 | (number->string (random 100000))) 13 | ; (bytes->string/utf-8 (list->bytes (for/list ([n 4]) (+ 49 (random 9)))))) 14 | 15 | (define (get-time/iso8601) 16 | (parameterize ([date-display-format 'iso-8601]) 17 | (match-define (list _ date time) 18 | (regexp-match 19 | #px"(\\d\\d\\d\\d-\\d\\d-\\d\\d)[MTWFS](\\d\\d:\\d\\d:\\d\\d)" 20 | (date->string (current-date) #t))) 21 | (++ date " " time))) 22 | 23 | ;; url utils 24 | (define (mk-link url txt) `(a ((href ,url)) ,txt)) 25 | 26 | ;; stx utils 27 | (define (stx->string stx) (to-string/s (syntax->datum stx))) 28 | 29 | 30 | ;; string-truncate : String -> String 31 | ;; Truncates the given str to len-limit chars, 32 | ;; or returns str unchanged if its length is <= len-limit 33 | (define (string-truncate str len-limit) 34 | (if (<= (string-length str) len-limit) 35 | str 36 | (substring str 0 len-limit))) 37 | 38 | (define (empty-string? str) 39 | (zero? (string-length str))) 40 | -------------------------------------------------------------------------------- /pasterack.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require web-server/servlet web-server/dispatch 4 | web-server/http/request-structs) 5 | (require xml xml/path net/url net/uri-codec json "recaptcha.rkt" 6 | "spam.rkt") 7 | (require racket/system racket/runtime-path syntax/modread) 8 | (require redis data/ring-buffer lang-file/read-lang-file) 9 | (require "pasterack-utils.rkt" "pasterack-parsing-utils.rkt" 10 | "pasterack-test-cases.rkt" "filter-pastes.rkt") 11 | 12 | (provide/contract (start (request? . -> . response?))) 13 | 14 | (define-runtime-path htdocs-dir "htdocs") 15 | (define-runtime-path here-dir ".") 16 | (define-runtime-path tmp-dir "tmp") 17 | 18 | ;(define pastebin-url "http://162.243.38.241:8000/") 19 | (define pastebin-url "http://pasterack.org/") 20 | ;(define pastebin-url "http://143.198.140.118/") 21 | (define paste-url-base (++ pastebin-url "pastes/")) 22 | (define racket-docs-url "http://docs.racket-lang.org/") 23 | (define racket-lang-url "http://racket-lang.org") 24 | (define racket-logo-url "http://racket-lang.org/logo.png") 25 | (define racket-irc-url "https://botbot.me/freenode/racket/") 26 | 27 | (define scrbl-exe "/home/pasterack/racket82/bin/scribble") 28 | 29 | (define PASTE-TITLE-DISPLAY-LEN 32) ; limit length of displayed title 30 | 31 | (define (mk-paste-url paste-num) (++ paste-url-base paste-num)) 32 | 33 | ;(define (mk-link url txt) `(a ((href ,url)) ,txt)) 34 | 35 | (define (fresh-str) 36 | (with-redis-connection 37 | (let loop () (define str (mk-rand-str)) (if (EXISTS str) (loop) str)))) 38 | 39 | ;; logging 40 | (define log-file (build-path here-dir "pasterack.log")) 41 | (define log-port (open-output-file log-file #:mode 'text #:exists 'append)) 42 | 43 | (unless (getenv "PLT_TR_NO_OPTIMIZE") 44 | (putenv "PLT_TR_NO_OPTIMIZE" "1")) 45 | 46 | (define sample-pastes 47 | '("8953" ; Sierpinski 48 | "5563" ; Greek letters 49 | "4837" ; lazy fib 50 | "3259" ; scribble syntax 51 | "8314" ; check-expect 52 | "7435" ; #lang htdp/bsl + 2htdp/image 53 | "3883" ; echo serv, test limits, and forms in racket but not racket/base 54 | "7658" ; typed/racket 55 | "97561"; plot 56 | "29314"; fish pict 57 | )) 58 | 59 | (define sample-pastes-htmls 60 | (let ([ns (with-redis-connection 61 | (do-MULTI (for ([p sample-pastes]) (send-cmd 'HGET p 'name))))]) 62 | (for/list ([name/bytes ns] [pnum sample-pastes]) 63 | (define name (bytes->string/utf-8 name/bytes)) 64 | `(tr (td ,(mk-link (mk-paste-url pnum) pnum)) 65 | (td ((style "width:1px"))) (td ,name))))) 66 | 67 | (define NUM-RECENT-PASTES 16) 68 | (define recent-pastes (empty-ring-buffer NUM-RECENT-PASTES)) 69 | (for ([p test-cases]) (ring-buffer-push! recent-pastes p)) 70 | 71 | (define TR-bad-ids 72 | (++ "#%module-begin with-handlers lambda λ #%top-interaction for for* " 73 | "define default-continuation-prompt-tag struct case-lambda let-values " 74 | "letrec-values for*/product let let* letrec define-struct for*/lists " 75 | "for*/hasheqv let/cc do for/and for/sum for/hasheq for/lists for*/and " 76 | "for*/hasheq for*/vector for/or for/hasheqv for*/last for*/or for/last " 77 | "for*/sum for/first for*/fold for/product for/hash for*/list let/ec " 78 | "for/list for/vector for*/hash for/fold for*/first let*-values")) 79 | (define plai-bad-ids "#%module-begin provide") 80 | 81 | ;; returns generated pastenum 82 | (define (write-codeblock-scrbl-file code modu pnum) 83 | (define tmp-scrbl-file (build-path tmp-dir pnum (++ pnum "code.scrbl"))) 84 | (define mod 85 | (with-handlers 86 | ([exn:fail? 87 | (lambda (e) 88 | ; most likely missing #lang 89 | (eprintf "~a\n\nCheck that paste includes #lang?" (exn-message e)) 90 | #'(module m racket/base (#%module-begin)))]) 91 | (check-module-form modu 'pasterack (++ "paste " pnum)))) 92 | (define lang (get-module-lang mod)) 93 | (define reqs 94 | (with-handlers ([exn:fail? (const null)]) ;; read fail = non-sexp syntax 95 | (get-module-reqs mod))) 96 | (define valid-reqs 97 | (string-join 98 | (map to-string/s 99 | (filter 100 | valid-req? 101 | (map syntax->datum reqs))))) 102 | (with-output-to-file tmp-scrbl-file 103 | (lambda () (printf 104 | (++ "#lang scribble/manual\n" 105 | "@(require racket/require)\n" 106 | "@(require (for-label " 107 | ;; when required id is also in lang, favor require (with subtract-in) 108 | (++ "(only-meta-in 0 " 109 | valid-reqs " " 110 | "(subtract-in (combine-in " 111 | (symbol->string (syntax->datum lang)) 112 | ")" 113 | " (combine-in " valid-reqs ")))") 114 | "))\n" 115 | "@codeblock|{\n~a}|") 116 | code)) 117 | #:mode 'text 118 | #:exists 'replace)) 119 | (define (write-eval-scrbl-file code mod pnum) 120 | (define lang (symbol->string (syntax->datum (get-module-lang mod)))) 121 | (define tmp-scrbl-file (build-path tmp-dir pnum (++ pnum "eval.scrbl"))) 122 | (define out (current-output-port)) 123 | (with-output-to-file tmp-scrbl-file 124 | (lambda () 125 | (cond 126 | ;; htdp lang only -------------------------------------------------- 127 | [(htdp-lang? lang) 128 | ;; separate code into exprs and other things 129 | ;; - exprs get evaled by interaction (ow pictures dont work) 130 | ;; - other top-level defs get included in make-module-evaluator 131 | ;; because they are not allowed in interactions 132 | (define-values (code-defs/checks code-exprs) 133 | (partition not-htdp-expr? (map syntax->datum (get-module-bodys mod)))) 134 | (printf 135 | (++ "#lang scribble/manual\n" 136 | "@(require scribble/eval racket/sandbox)\n" 137 | "@(define-namespace-anchor anchor)\n" 138 | "@(define the-eval\n" 139 | " (parameterize ([sandbox-output 'string]\n" 140 | " [sandbox-error-output 'string]\n" 141 | " [sandbox-propagate-breaks #f]\n" 142 | " [sandbox-namespace-specs " 143 | "(cons " 144 | "(lambda () (namespace-anchor->namespace anchor)) " 145 | "'(racket/pretty file/convertible))]\n" 146 | " [sandbox-path-permissions " 147 | "'([read \"/home/pasterack/pasterack/tmp/\"]\n" 148 | ;; images seem to need access to the prefs file 149 | "[read \"/home/pasterack/.racket/\"]\n" 150 | "[read \"/home/pasterack/.config/\"]\n" ; prefs moved here? (v8?) 151 | ;; 2htdp/image performs exists? checks on libpng 152 | "[exists \"/\"])]\n" 153 | " [sandbox-eval-limits '(20 128)])\n" 154 | " (let ([e (make-module-evaluator " 155 | "'(module m " lang 156 | " (require test-engine/racket-tests) " 157 | (string-join (map to-string/s code-defs/checks)) 158 | " (test))" 159 | ")])\n" 160 | " (call-in-sandbox-context e\n" 161 | " (lambda ()\n" 162 | " (current-print (dynamic-require 'racket/pretty " 163 | "'pretty-print-handler))))\n" 164 | " e)))\n" 165 | "@interaction[#:eval the-eval\n" 166 | (string-join (map to-string/s code-exprs)) 167 | " (test)]"))] 168 | ;; non htdp lang -------------------------------------------------- 169 | [else 170 | (define datums (map syntax->datum (get-module-bodys mod))) 171 | ; (for ([d datums]) (fprintf out "~a\n" d)) 172 | (define-values (mod-datums expr-datums) 173 | (parameterize ([current-namespace (make-base-namespace)]) 174 | (eval `(require ,(string->symbol lang))) 175 | (partition (lambda (d) (not-expr? d out)) datums))) 176 | ;; (fprintf out "mod datums: ~a\n" (string-join (map to-string/s mod-datums))) 177 | ;; (fprintf out "expr datums: ~a\n" (string-join (map to-string/s expr-datums))) 178 | (display 179 | ; (printf 180 | (++ "#lang scribble/manual\n" 181 | "@(require scribble/eval racket/sandbox)\n" 182 | "@(define-namespace-anchor anchor)\n" 183 | "@(define the-eval\n" 184 | " (parameterize ([sandbox-output 'string]\n" 185 | " [sandbox-error-output 'string]\n" 186 | " [sandbox-propagate-breaks #f]\n" 187 | " [sandbox-namespace-specs " 188 | "(cons " 189 | "(lambda () (namespace-anchor->namespace anchor)) " 190 | "'(racket/pretty file/convertible))]\n" 191 | " [sandbox-path-permissions " 192 | "'([read \"/home/pasterack/pasterack/tmp/\"]" 193 | "[read \"/home/pasterack/.racket/\"]\n" 194 | "[read \"/home/pasterack/.config/\"]\n" ; prefs moved here? (v8?) 195 | ;; 2htdp/image performs exists? checks on libpng 196 | "[exists \"/\"])]\n" 197 | " [sandbox-eval-limits '(20 128)])\n" 198 | ; " (let ([e (make-evaluator '" lang ")])\n" 199 | " (let ([e (make-module-evaluator " 200 | "'(module m " lang "\n" 201 | (string-join (map to-string/s mod-datums)) 202 | "))])\n" 203 | " (call-in-sandbox-context e\n" 204 | " (lambda ()\n" 205 | " (current-print (dynamic-require 'racket/pretty " 206 | "'pretty-print-handler))))\n" 207 | " e)))\n" 208 | ;; "@interaction[#:eval the-eval\n~a]") 209 | ;; code-no-lang)])) 210 | "@interaction[#:eval the-eval\n(void)\n" 211 | (string-join (map to-string/s expr-datums)) 212 | "]") 213 | )])) 214 | #:mode 'text 215 | #:exists 'replace)) 216 | 217 | (define (compile-scrbl-file/get-html pnum) 218 | (define new-tmpdir (build-path tmp-dir pnum)) 219 | (define scrbl-file (build-path new-tmpdir (++ pnum "code.scrbl"))) 220 | (define html-file (build-path new-tmpdir (++ pnum "code.html"))) 221 | (and (system (++ scrbl-exe " --html " 222 | "+m --redirect-main " racket-docs-url " " 223 | "--dest " (path->string new-tmpdir) " " 224 | (path->string scrbl-file))) 225 | (with-input-from-file html-file port->bytes))) 226 | (define (compile-eval-scrbl-file/get-html pnum) 227 | (define new-tmpdir (build-path tmp-dir pnum)) 228 | (define scrbl-file (build-path new-tmpdir (++ pnum "eval.scrbl"))) 229 | (define html-file (build-path new-tmpdir (++ pnum "eval.html"))) 230 | (and (system (++ scrbl-exe " --html " 231 | "--dest " (path->string new-tmpdir) " " 232 | (path->string scrbl-file))) 233 | (with-input-from-file html-file port->bytes))) 234 | 235 | ;; files/directories layout --------------------------------------------------- 236 | ;; web-server files are in htdocs/ 237 | ;; each paste creates a directory tmp/ 238 | ;; - scrbl for code is tmp//code.scrbl 239 | ;; - compiled code is tmp//code.html 240 | ;; -- if code scrbl file couldn't be compiled, then error is in 241 | ;; tmp//code.err 242 | ;; - scrbl for eval is tmp//eval.scrbl 243 | ;; - compiled eval is tmp//eval.html 244 | ;; -- if eval results in 1 pict: tmp//pict.png 245 | ;; -- if eval results in n picts: tmp//pict_1.png through pict_n.png 246 | 247 | ;; generate-paste-html : String Syntax String -> HTML 248 | ;; code = pasted code 249 | ;; mod = `read`ed pasted code 250 | (define (generate-paste-html code mod pastenum) 251 | (define paste-dir (build-path tmp-dir pastenum)) 252 | (unless (directory-exists? paste-dir) (make-directory paste-dir)) 253 | ;; read.err contains errs before the compile, eg missing #lang 254 | ;; needed otherwise extraneous scribble warnings will be displayed 255 | (define read-err (open-output-file (build-path paste-dir (++ pastenum "read.err")))) 256 | (parameterize ([current-error-port read-err]) 257 | (write-codeblock-scrbl-file code mod pastenum)) 258 | (close-output-port read-err) 259 | (define err (open-output-file (build-path paste-dir (++ pastenum "code.err")))) 260 | (parameterize ([current-error-port err]) 261 | (begin0 (compile-scrbl-file/get-html pastenum) 262 | (close-output-port err)))) 263 | (define (generate-eval-html code mod pastenum) 264 | ;; should check that tmp/pastenum dir exists here 265 | (write-eval-scrbl-file code mod pastenum) 266 | (compile-eval-scrbl-file/get-html pastenum)) 267 | 268 | (define google-analytics-script 269 | (++ "var _gaq = _gaq || [];\n" 270 | "_gaq.push(['_setAccount', 'UA-44480001-1']);\n" 271 | "_gaq.push(['_trackPageview']);\n" 272 | "(function() {\n" 273 | "var ga = document.createElement('script'); " 274 | "ga.type = 'text/javascript'; ga.async = true;\n" 275 | "ga.src = ('https:' == document.location.protocol " 276 | "? 'https://ssl' : 'http://www') + '.google-analytics.com/ga.js';\n" 277 | "var s = document.getElementsByTagName('script')[0];" 278 | "s.parentNode.insertBefore(ga, s);\n" 279 | "})();")) 280 | (define twitter-script 281 | (++ "!function(d,s,id){" 282 | "var js,fjs=d.getElementsByTagName(s)[0]," 283 | "p=/^http:/.test(d.location)?'http':'https';" 284 | "if(!d.getElementById(id)){" 285 | "js=d.createElement(s);js.id=id;" 286 | "js.src=p+'://platform.twitter.com/widgets.js';" 287 | "fjs.parentNode.insertBefore(js,fjs);}}" 288 | "(document, 'script', 'twitter-wjs');")) 289 | 290 | (define codemirror-script 291 | "var codeMirror = CodeMirror.fromTextArea(document.getElementById(\"paste\"),\ 292 | { lineNumbers : true, matchBrackets : true, theme: \"neat\" } 293 | );") 294 | 295 | (define droidsansmono-css/x 296 | '(link ([type "text/css"] [rel "stylesheet"] 297 | [href "http://fonts.googleapis.com/css?family=Droid+Sans+Mono"]))) 298 | (define ptsans-css/x 299 | '(link ([type "text/css"] [rel "stylesheet"] 300 | [href "http://fonts.googleapis.com/css?family=PT+Sans"]))) 301 | (define scrbl-css/x 302 | '(link ([type "text/css"] [rel "stylesheet"] 303 | [href "http://pasterack.org/scribble.css"]))) 304 | (define scrbl-style-css/x 305 | '(link ([type "text/css"] [rel "stylesheet"] 306 | [href "http://pasterack.org/scribble-style.css"]))) 307 | (define rkt-css/x 308 | '(link ([type "text/css"] [rel "stylesheet"] 309 | [href "http://pasterack.org/racket.css"]))) 310 | 311 | 312 | ;; generate SUBMIT button image 313 | ;; (require images/icons/control) 314 | ;; (require images/icons/style) 315 | ;; (require pict racket/draw) 316 | ;; (send 317 | ;; (pict->bitmap 318 | ;; (cc-superimpose 319 | ;; (bitmap (record-icon #:color (make-object color% 64 64 255) #:height 64 320 | ;; #:material glass-icon-material)) 321 | ;; (bitmap (play-icon #:color light-metal-icon-color #:height 32 322 | ;; #:material metal-icon-material)))) 323 | ;; save-file "htdocs/submit.png" 'png) 324 | 325 | (define-syntax-rule (~~ prop ...) (string-join (list prop ...) ";")) 326 | 327 | ;; ---------------------------------------------------------------------------- 328 | ;; serve home ----------------------------------------------------------------- 329 | (define (serve-home request #:title [title ""] 330 | #:content [content "#lang racket"] 331 | #:fork-from [fork-from ""] 332 | #:status [status ""]) 333 | (define (response-generator embed/url) 334 | (response/xexpr 335 | `(html ([style ,(~~ "background-image:url('/plt-back.1024x768.png')" 336 | "background-attachment:fixed" 337 | "background-size:cover")]) 338 | ;; head ---------------------------------------------------------------- 339 | (head 340 | ; (title "PasteRack (MIRROR): A Racket-evaluating pastebin") 341 | (title "PasteRack: A Racket-evaluating pastebin") 342 | (script ([type "text/javascript"]) ,google-analytics-script) 343 | (script ([src "https://www.google.com/recaptcha/api.js"])) 344 | ,droidsansmono-css/x ,ptsans-css/x 345 | ;; expects a codemirror.js script and its scheme mode in htdocs 346 | (script ([src "/codemirror.js"] [type "text/javascript"])) 347 | (link ((rel "stylesheet") (href "/codemirror.css"))) 348 | (link ((rel "stylesheet") (href "/neat.css"))) 349 | (style ,(string-append ".CodeMirror { text-align: left; background: #FFFFF0;" 350 | " font-size: 15px; height: 35em;" 351 | " font-family: Droid Sans Mono, monospace;" 352 | " border: thin gray inset; width: 50em; }")) 353 | ) 354 | ;; body ---------------------------------------------------------------- 355 | (body ((style "font-family:'PT Sans',sans-serif")) 356 | ; (h1 "MIRROR") 357 | ;; left -------------------------------------------------------------- 358 | (div ((style ,(~~ "position:absolute;left:1em;top:2em" 359 | "width:12em" 360 | "font-size:95%"))) 361 | (h4 "Total pastes: " ,(number->string (DBSIZE))) 362 | (h4 "Sample pastes:") 363 | (table ((style "margin-top:-15px;font-size:95%")) 364 | ,@sample-pastes-htmls) 365 | (h4 "Recent pastes:") 366 | (table ((style "margin-top:-15px;font-size:95%")) 367 | ,@(reverse 368 | (with-redis-connection 369 | (for/list ([pnum recent-pastes] #:when pnum 370 | #:when (HGET/str pnum 'name)) 371 | (define name (HGET/str pnum 'name)) 372 | (define trunc-name 373 | (string-truncate name PASTE-TITLE-DISPLAY-LEN)) 374 | `(tr (td ,(mk-link (mk-paste-url pnum) pnum)) 375 | (td ((style "width:1px"))) (td ,trunc-name))))))) 376 | ;; middle ------------------------------------------------------------ 377 | (div ((style ,(~~ "position:absolute;left:14em;top:2em"))) 378 | (center 379 | (img ((src ,racket-logo-url))) 380 | (h2 ,(mk-link pastebin-url "PasteRack") 381 | ": An evaluating pastebin for " 382 | ,(mk-link racket-lang-url "Racket") (small " (v" ,(version) ")")) 383 | (form ([action ,(embed/url check-paste)] [method "post"]) 384 | (div 385 | (input ([type "text"] [name "name"] [size "60"] [value ,title] 386 | [style ,(~~ "background-color:#FFFFF0" 387 | "border:inset thin" 388 | "font-size:105%" 389 | "font-family:'PT Sans',sans-serif")])) 390 | (span ([style "font-size:90%"]) " (paste title)")) 391 | (br) 392 | (textarea ([id "paste"] [name "paste"]) ,content) 393 | ;; run script after textarea is evaluated 394 | (script ([type "text/javascript"]) ,codemirror-script) 395 | (input ([type "hidden"] [name "fork-from"] [value ,fork-from])) 396 | (br) 397 | (table (tr 398 | ;; submit button ------------- 399 | (td ((style "width:5em")) 400 | (input ([type "image"] [alt "Submit Paste and Run"] 401 | [src "/submit.png"]))))) 402 | (span ,status) 403 | (br) 404 | (span "Paste must be a valid #lang program.") 405 | (br) 406 | (span ,(if (string=? "" fork-from) "" 407 | `(span "Forked from paste # " 408 | ,(mk-link 409 | (++ paste-url-base fork-from) fork-from)))) 410 | (br) 411 | (div ([class "g-recaptcha"] 412 | [data-sitekey "6LdM0wYTAAAAAJPls_eNV28XvCRMeaf1cDoAV4Qx"]) 413 | "Please check the box:")) 414 | (br)(br)(br) 415 | ;; middle bottom (part of middle) ------------------------------------ 416 | (div ([style "font-size:small;color:#808080"]) 417 | "Powered by " ,(mk-link racket-lang-url "Racket") ". " 418 | "View " 419 | ,(mk-link "https://github.com/stchang/pasterack" "source") "." 420 | " Report issues or suggestions " 421 | ,(mk-link "https://github.com/stchang/pasterack/issues" "here") ". " 422 | "Inspired by " 423 | ,(mk-link "https://github.com/samth/paste.rkt" "paste.rkt") "." 424 | ) 425 | )) 426 | )))) 427 | (send/suspend/dispatch response-generator)) 428 | 429 | (define (serve-home/prefill request content [title ""]) 430 | (serve-home request #:title title #:content content)) 431 | 432 | (define (check-paste request) 433 | (define bs (request-bindings request)) 434 | (define name (extract-binding/single 'name bs)) 435 | (define as-text? (exists-binding? 'astext bs)) 436 | (define captcha-token (extract-binding/single 'g-recaptcha-response bs)) 437 | (define paste-content (extract-binding/single 'paste bs)) 438 | (define fork-from (extract-binding/single 'fork-from bs)) 439 | (define lang/#f ; ban pastes that are not valid #lang program 440 | (call-with-input-string paste-content read-lang)) 441 | (define-values (status headers captcha-success-in) 442 | (http-sendrecv/url 443 | (string->url "https://www.google.com/recaptcha/api/siteverify") 444 | #:method "POST" 445 | #:data (alist->form-urlencoded 446 | (list (cons 'secret RECAPTCHA-SECRET) 447 | (cons 'response captcha-token) 448 | (cons 'remoteip (request-client-ip request)))) 449 | #:headers '("Content-Type: application/x-www-form-urlencoded"))) 450 | (define captcha-success? 451 | (hash-ref (read-json captcha-success-in) 'success #f)) 452 | ;; very basic spam filter TODO: move check to client-side? 453 | (if (and lang/#f 454 | captcha-success? 455 | (not (contains-banned? name)) 456 | (not (contains-banned? paste-content))) 457 | (process-paste request as-text?) 458 | (serve-home request 459 | #:title name 460 | #:content paste-content 461 | #:fork-from fork-from 462 | #:status '(span "Invalid paste: possibly captcha failed or invalid #lang program.")))) 463 | 464 | (define (process-paste request [as-text? #f]) 465 | (define bs (request-bindings request)) 466 | (cond 467 | [(exists-binding? 'paste bs) 468 | (define paste-num (fresh-str)) 469 | (define paste-name (extract-binding/single 'name bs)) 470 | (define pasted-code (extract-binding/single 'paste bs)) 471 | (define fork-from (extract-binding/single 'fork-from bs)) 472 | (define mod-stx 473 | (with-handlers ([exn:fail? 474 | (lambda (e) 475 | ; either scribble will properly report read error, 476 | ; eg, unbalanced parens, 477 | ; or #lang missing and check-module-form will catch, 478 | ; so just return dummy module to continue 479 | #'(module m racket/base (#%module-begin)))]) 480 | (call-with-input-string pasted-code read-lang-module))) 481 | (define html-res 482 | (if as-text? #f (generate-paste-html pasted-code mod-stx paste-num))) 483 | (define paste-html-str (or html-res pasted-code)) 484 | (define read-err-str 485 | (if as-text? "" 486 | (with-input-from-file 487 | (build-path tmp-dir paste-num (++ paste-num "read.err")) 488 | port->string))) 489 | ;; html-res = #f means "as text" or scrbl compile fail (ie, read fail) 490 | ;; only eval on typeset compile success and no other errs 491 | (define eval-html-str 492 | (if (and html-res (empty-string? read-err-str)) 493 | (generate-eval-html pasted-code mod-stx paste-num) 494 | ;; if not, use read error as output, 495 | ;; unless as-text was explicitly checked 496 | (cond [as-text? #f] 497 | [(non-empty-string? read-err-str) read-err-str] 498 | [else 499 | (with-input-from-file 500 | (build-path tmp-dir paste-num (++ paste-num "code.err")) 501 | port->string)]))) 502 | (define paste-url (mk-paste-url paste-num)) 503 | (ring-buffer-push! recent-pastes paste-num) 504 | (define tm-str (get-time/iso8601)) 505 | (SET/hash paste-num (hash 'name paste-name 506 | 'code pasted-code 507 | 'code-html paste-html-str 508 | 'eval-html (or eval-html-str "") 509 | 'time tm-str 510 | 'fork-from fork-from 511 | 'views 0)) 512 | (fprintf log-port "~a\t~a\t~a\t~a\n" 513 | tm-str paste-num paste-name (request-client-ip request)) 514 | (redirect-to paste-url permanently)] 515 | [else 516 | (response/xexpr 517 | `(html () 518 | (head ()) 519 | (body () "ERROR: bad paste" ,(mk-link pastebin-url "Go Back"))))])) 520 | 521 | (define (get-main-div html-bytes) 522 | (with-handlers ([exn:fail? (lambda (x) (bytes->string/utf-8 html-bytes))]) 523 | (car (filter 524 | (lambda (d) (equal? "main" (se-path* '(div #:class) d))) 525 | (se-path*/list '(div) 526 | (xml->xexpr (document-element 527 | (with-input-from-bytes html-bytes read-xml)))))))) 528 | 529 | (define (serve-raw-paste request pastenum) 530 | (define retrieved-paste-hash 531 | (with-redis-connection 532 | (when (HEXISTS pastenum 'views) (HINCRBY pastenum 'views 1)) 533 | (GET/hash pastenum #:map-key bytes->symbol))) 534 | (match retrieved-paste-hash 535 | [(hash-table ('name paste-name) ('code code) ('code-html code-html) 536 | ('eval-html eval-html) ('time time-str) 537 | ('fork-from fork-from) ('views views)) 538 | (response/xexpr (bytes->string/utf-8 code) #:mime-type #"text/plain; charset=utf-8")] 539 | [_ 540 | (response/xexpr 541 | `(html() (head (title "Paste not found")) 542 | (body () 543 | ,(format "Paste # ~a doesn't exist." pastenum) (br) 544 | ,(mk-link pastebin-url "Go Back"))))])) 545 | 546 | (define (serve-paste request pastenum) 547 | (define retrieved-paste-hash 548 | (with-redis-connection 549 | (when (HEXISTS pastenum 'views) (HINCRBY pastenum 'views 1)) 550 | (GET/hash pastenum #:map-key bytes->symbol))) 551 | (cond 552 | [(equal? (hash) retrieved-paste-hash) 553 | (response/xexpr 554 | `(html() (head (title "Paste not found")) 555 | (body () 556 | ,(format "Paste # ~a doesn't exist." pastenum) (br) 557 | ,(mk-link pastebin-url "Go Back"))))] 558 | [else 559 | (define-values (name code code-html eval-html time-str fork-from views) 560 | (match retrieved-paste-hash 561 | [(hash-table ('name paste-name) ('code code) ('code-html code-html) 562 | ('eval-html eval-html) ('time time-str) 563 | ('fork-from fork-from) ('views views)) 564 | (values (bytes->string/utf-8 paste-name) 565 | (bytes->string/utf-8 code) 566 | code-html eval-html 567 | (bytes->string/utf-8 time-str) 568 | (bytes->string/utf-8 fork-from) 569 | (bytes->string/utf-8 views))] 570 | ;; old record layouts 571 | [(hash-table ('name paste-name) ('code code-html) 572 | ('eval eval-html) ('time time-str)) 573 | (values (bytes->string/utf-8 paste-name) 574 | "" code-html eval-html 575 | (bytes->string/utf-8 time-str) "" "")])) 576 | (define code-main-div (get-main-div code-html)) 577 | (define eval-main-div (get-main-div eval-html)) 578 | (define paste-url (string-append paste-url-base pastenum)) 579 | 580 | ;; move-image-file: html -> html 581 | ;; '(img ((alt "image") ,height (src ,filename) ,width)) 582 | ;; => 583 | ;; '(img ((alt "image") ,height (src ,new-filename) ,width)) 584 | ;; side effect: moves pict file from tmp dir to permanent location in htdocs 585 | (define (move-image-file filename height width 586 | [style '(style "")]) 587 | ;; rename file to avoid future clashes 588 | (define rxmatch 589 | (regexp-match #px"^(pict|\\d+)\\_*(\\d+)*\\.png" 590 | filename)) 591 | (unless rxmatch 592 | (error "scribble made non-pict.png ~a" filename)) 593 | (match-define (list _ base offset) rxmatch) 594 | (define new-file 595 | (++ pastenum (if offset (++ "_" offset) "") ".png")) 596 | (define curr-file-path 597 | (build-path tmp-dir pastenum filename)) 598 | (define new-file-path 599 | (build-path htdocs-dir new-file)) 600 | (unless (file-exists? new-file-path) 601 | (copy-file curr-file-path new-file-path) 602 | (delete-file curr-file-path)) 603 | `(img ((alt "image") 604 | ,height (src ,(++ pastebin-url new-file)) ,style ,width))) 605 | ;; should be a flat list of elems, even for nested lists 606 | (define (move-image-files lst) 607 | (for/list ([elem lst]) 608 | (match elem 609 | ;; 611 added a "style" field 610 | [`(img ((alt "image") ,height (src ,filename) ,style ,width)) 611 | (move-image-file filename height width style)] 612 | [`(img ((alt "image") ,height (src ,filename) ,width)) 613 | (move-image-file filename height width)] 614 | [x x]))) 615 | (define main-html 616 | (match code-main-div 617 | [`(div ((class "main")) ,ver 618 | (blockquote ((class "SCodeFlow")) 619 | (table ,table-params . ,rows))) 620 | (define new-rows 621 | (map 622 | (lambda (r) 623 | (match r 624 | [`(tr () (td () . ,rst)) 625 | `(li (span ((style "font-family:'Droid Sans Mono',monospace;font-size:125%")) . ,rst))] 626 | [_ r])) 627 | rows)) 628 | ; `(div ;((class "main")) 629 | `(div ([style ,(~~ "font-family:'Droid Sans Mono',monospace" 630 | "background-color:transparent")]) 631 | ; (blockquote ;((class "SCodeFlow")) 632 | (ol ((start "0")(style "font-size:70%;color:#A0A0A0")) 633 | . ,new-rows) 634 | (p "=>") 635 | ,(match eval-main-div 636 | [`(div ((class "main")) ,ver 637 | (blockquote ,attr1 (table ,attr2 . ,results))) 638 | ; `(blockquote ,attr1 (table ,attr2 . 639 | `(blockquote (table ([style ,(~~ "font-size:90%" 640 | "table-layout:fixed" 641 | "width:100%" 642 | "word-wrap:break-word")]) . 643 | ,(filter 644 | identity 645 | (map ; either rewrites html or produces #f to be filtered 646 | (lambda (x) 647 | (match x 648 | ;; single-line evaled expr (with ">" prompt), skip 649 | [`(tr () (td () (span ((class "stt")) ">" " ") . ,rst)) 650 | #f] 651 | ;; multi-line evaled expr 652 | [`(tr () (td () 653 | (table ((cellspacing "0") 654 | (class "RktBlk")) 655 | (tr () (td () (span ((class "stt")) ">" " ") 656 | . ,rst1)) . ,rst))) #f] 657 | ;; void result, skip 658 | [`(tr () (td () (table ,attr (tr () (td ()))))) #f] 659 | ;; rewrite filename in image link (1st case): 660 | ;; html of img output (for pict) has changed (in 611?) 661 | ;; new "style" field added, so handle as separate case 662 | [`(tr () (td () (p () 663 | (img ((alt "image") 664 | ,height (src ,filename) ,style ,width))))) 665 | ;; renames file to avoid future clashes 666 | ;; and rewrites html with new filename 667 | `(tr () (td () (p () 668 | ,(move-image-file filename height width style))))] 669 | ;; fix filename in image link (2nd case) 670 | ;; (this was the only case before 611) 671 | [`(tr () (td () (p () 672 | (img ((alt "image") ,height (src ,filename) ,width))))) 673 | ;; renames file to avoid future clashes 674 | ;; and rewrites html with new filename 675 | `(tr () (td () (p () 676 | ,(move-image-file filename height width))))] 677 | ;; list(s) of images 678 | [`(tr () (td () (p () 679 | (span ((class "RktRes")) "'(") . ,rst))) 680 | `(tr () (td () (p () 681 | (span ((class "RktRes")) "'(") 682 | ,@(move-image-files rst))))] 683 | ;; nested table 684 | [`(tr () (td () (table ,attrs . ,rows))) 685 | `(tr () (td () (table ([style ,(~~ "font-size:95%" 686 | "table-layout:fixed" 687 | "width:100%" 688 | "word-wrap:break-word")]) 689 | . ,rows)))] 690 | [x x])) 691 | results))))] 692 | [_ `(div (pre ,eval-main-div))]))] 693 | [_ `(div (pre ,code-main-div) 694 | ,(if (string=? eval-main-div "") "" 695 | `(span (p "=>") (pre ,eval-main-div))) 696 | )])) 697 | (serve-home #:content code #:title name #:fork-from pastenum 698 | (send/suspend 699 | (lambda (home-url) 700 | (response/xexpr 701 | `(html ([style ,(~~ "background-image:url('/plt-back.1024x768.png')" 702 | "background-attachment:fixed" 703 | "background-size:cover")]) 704 | (head () 705 | (meta ((content "text-html; charset=utf-8") 706 | (http-equiv "content-type"))) 707 | (title ,(++ "Paste # " pastenum ": " name)) 708 | ,scrbl-css/x ,rkt-css/x ,scrbl-style-css/x 709 | ,droidsansmono-css/x ,ptsans-css/x 710 | (script ((src "/scribble-common.js") (type "text/javascript"))) 711 | (script ,twitter-script)) 712 | (body ([style ,(~~ "font-family:'PT Sans',sans-serif" 713 | "background-color:transparent")]) 714 | ;; left ---------------------------------------------------------------- 715 | (div ([style "position:absolute;left:1em;top:2em"]) 716 | (table ([cellspacing "0"] [cellpadding "0"]) 717 | (tr (td ,(mk-link pastebin-url "PasteRack.org"))) 718 | (tr (td ((height "10px")))) 719 | (tr (td "Paste # " (a ((href ,paste-url)) ,pastenum))) 720 | (tr (td ([colspan "3"] [style "font-size:90%"]) ,time-str)) 721 | (tr (td ,(if (string=? "" fork-from) "" 722 | `(span (br) "Forked from paste # " 723 | ,(mk-link (++ paste-url-base fork-from) fork-from) 724 | ".")))) 725 | (tr (td 726 | ,(if (string=? "" code) "" 727 | `(span (br) (a ([href ,home-url]) "Fork") " as a new paste.")))) 728 | (tr (td ,(if (string=? "" views) "" 729 | `(span (br) "Paste viewed " ,views " time" 730 | ,(if (string=? "1" views) "." "s."))))) 731 | (tr (td (br) 732 | (a ([href "https://twitter.com/share"][class "twitter-share-button"] 733 | [data-related "racketlang"][data-dnt "true"]) "Tweet"))) 734 | (tr (td (br) "Embed:")) 735 | (tr (td (textarea ([rows "2"][cols "16"]) 736 | ,(xexpr->string scrbl-css/x) 737 | ,(xexpr->string rkt-css/x) 738 | ,(xexpr->string droidsansmono-css/x) 739 | ,(xexpr->string main-html)))))) 740 | ;; middle -------------------------------------------------------------- 741 | (div ((style "position:absolute;left:14em")) 742 | ,(if (string=? name "") '(br) `(h4 ,name)) 743 | ,main-html)))))) )])) 744 | 745 | (define (serve-search request searchpat) 746 | (response/xexpr 747 | `(html () (head (title "Search results: " searchpat)) 748 | (body () 749 | (table () 750 | . ,(for/list ([k (KEYS "*")] 751 | #:when (and (string=? (TYPE k) "hash") 752 | (HEXISTS k 'code) ; valid paste 753 | (let ([paste-contents (HGET/str k 'code)] 754 | [paste-name (HGET/str k 'name)]) 755 | (or (contains-pat? searchpat paste-contents) 756 | (contains-pat? searchpat paste-name))))) 757 | (define pnum (bytes->string/utf-8 k)) 758 | `(tr (td ,(mk-link (mk-paste-url pnum) pnum)) 759 | (td ((style "width:1px"))) (td ,(HGET/str k 'name))))))))) 760 | 761 | (define (serve-tests request) 762 | (define test-cases-htmls 763 | (let ([ns (with-redis-connection 764 | (do-MULTI (for ([p test-cases]) (send-cmd 'HGET p 'name))))]) 765 | (for/list ([name/bytes ns] [pnum test-cases]) 766 | (define name (bytes->string/utf-8 name/bytes)) 767 | `(tr (td ,(mk-link (mk-paste-url pnum) pnum)) 768 | (td ((style "width:1px"))) (td ,name))))) 769 | (response/xexpr 770 | `(html ([style ,(~~ "background-image:url('/plt-back.1024x768.png')" 771 | "background-attachment:fixed" 772 | "background-size:cover")]) 773 | ;; head ---------------------------------------------------------------- 774 | (head 775 | (title "PasteRack: Test Cases") 776 | (link ([type "text/css"] [rel "stylesheet"] 777 | [href "http://fonts.googleapis.com/css?family=PT+Sans"])) 778 | (link ([type "text/css"] [rel "stylesheet"] 779 | [href "http://fonts.googleapis.com/css?family=Droid+Sans+Mono"]))) 780 | ;; body ---------------------------------------------------------------- 781 | (body ((style "font-family:'PT Sans',sans-serif")) 782 | (div ((style ,(~~ "position:absolute;left:1em;top:2em" 783 | "width:20em" 784 | "font-size:95%"))) 785 | (h4 "Test Cases:") 786 | (table ((style "margin-top:-15px;font-size:95%")) 787 | ,@test-cases-htmls)))))) 788 | 789 | (require "plt-bacon.rkt") 790 | (define-values (do-dispatch mk-url) 791 | (dispatch-rules 792 | [("") serve-home] 793 | [("paste" (string-arg)) serve-home/prefill] ; prefill content 794 | [("paste" (string-arg) (string-arg)) serve-home/prefill] ; prefill w/ title 795 | [("pastes" (string-arg) "raw") serve-raw-paste] 796 | [("pastes" (string-arg)) serve-paste] 797 | [("search" (string-arg)) serve-search] 798 | [("tests") serve-tests] 799 | [("bacon") serve-bacon] 800 | #;[else serve-home])) 801 | 802 | 803 | (define (start request) (do-dispatch request)) 804 | 805 | (require web-server/servlet-env) 806 | (serve/servlet start 807 | #:launch-browser? #f 808 | #:quit? #f 809 | #:listen-ip #f 810 | #:port 8000 811 | #:extra-files-paths (list htdocs-dir) 812 | #:servlet-path "/" 813 | #:servlet-regexp #rx".*") 814 | -------------------------------------------------------------------------------- /plt-bacon.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require 3 | web-server/servlet web-server/servlet-env 4 | web-server/formlets web-server/formlets/servlet 5 | net/url 6 | graph) 7 | 8 | ;; scrape data ---------------------------------------------------------------- 9 | (define PLT-PUBS-URL (string->url "http://www.ccs.neu.edu/racket/pubs/")) 10 | (define neu-pubs-port (get-pure-port PLT-PUBS-URL)) 11 | ;(define neu-pubs-port (open-input-file "plt-pubs.html")) 12 | 13 | (define name-pat "([A-Z][a-z\\-]+\\s?)+") 14 | (define word-pat "([A-Za-z\\-]+\\s?)+") 15 | (define names-pat (string-append "(" name-pat ",\\s)+" name-pat)) 16 | (define title-pat (string-append "(?<=)\\s+(" word-pat ")+")) 17 | (define authors-px 18 | (pregexp 19 | (string-append "(?<=:|
)\\s*" names-pat ".+?" title-pat))) 20 | 21 | (define matches (regexp-match* authors-px neu-pubs-port)) 22 | 23 | ;; authors+title : [Listof author-string ... title-string] 24 | (define authors+title 25 | (for/list ([authors matches]) 26 | (define as+title 27 | (string-split (string-trim (bytes->string/utf-8 authors)) #px",\\s+")) 28 | (define last-auth+title 29 | (car (reverse as+title))) 30 | (define first-authors 31 | (reverse (cdr (reverse as+title)))) 32 | (define last-auth+title-match 33 | (regexp-split #px"\\s+
|\\s+" last-auth+title)) 34 | (define as+t 35 | (append first-authors 36 | (list (first last-auth+title-match) 37 | (string-trim (car (reverse last-auth+title-match)))))) 38 | as+t)) 39 | 40 | ;; populate graph ------------------------------------------------------------- 41 | (define PLT-GRAPH (unweighted-graph/undirected null)) 42 | (define-edge-property PLT-GRAPH papers) 43 | 44 | (for ([as+t authors+title]) 45 | (define authors (cdr (reverse as+t))) 46 | (define title (car (reverse as+t))) 47 | (for* ([auth1 authors] 48 | [auth2 authors] 49 | #:unless (string=? auth1 auth2)) 50 | (define papers-curr (papers auth1 auth2 #:default null)) 51 | (add-edge! PLT-GRAPH auth1 auth2) 52 | (papers-set! auth1 auth2 (cons title papers-curr)))) 53 | 54 | ;; print to stdout ------------------------------------------------------------ 55 | #;(define (plt-bacon auth erdos bacon) 56 | (define erdos-path (fewest-vertices-path PLT-GRAPH auth erdos)) 57 | (define bacon-path (fewest-vertices-path PLT-GRAPH auth bacon)) 58 | ;; print erdos path 59 | (for ([a1 erdos-path] 60 | [a2 (cdr erdos-path)]) 61 | (printf "~a co-authored with ~a:\n" a1 a2) 62 | (for ([p (papers a1 a2)]) 63 | (printf " ~a\n" p))) 64 | (define erdos-num (sub1 (length erdos-path))) 65 | (printf "\n** ~a's ~a-number is: ~a\n\n" auth erdos erdos-num) 66 | ;; print bacon path 67 | (for ([a1 bacon-path] 68 | [a2 (cdr bacon-path)]) 69 | (printf "~a co-authored with ~a:\n" a1 a2) 70 | (for ([p (papers a1 a2)]) 71 | (printf " ~a\n" p))) 72 | (define bacon-num (sub1 (length bacon-path))) 73 | (printf "\n** ~a's ~a-number is: ~a\n\n" auth bacon bacon-num) 74 | (printf "## ~a's ~a-~a-number is: ~a\n" 75 | auth erdos bacon 76 | (+ erdos-num bacon-num))) 77 | 78 | ;; html output ---------------------------------------------------------------- 79 | (define (plt-bacon-html auth erdos bacon) 80 | (define erdos-path (fewest-vertices-path PLT-GRAPH auth erdos)) 81 | (define bacon-path (fewest-vertices-path PLT-GRAPH auth bacon)) 82 | (define erdos-num (sub1 (length erdos-path))) 83 | (define bacon-num (sub1 (length bacon-path))) 84 | `(table 85 | (tr "Computed " 86 | (i ,auth) 87 | "'s " 88 | (b ,erdos) "-" (b ,bacon) " number:") 89 | (tr (br) (hr)) 90 | (tr 91 | ;; print erdos path 92 | ,@(for/list ([a1 erdos-path] 93 | [a2 (cdr erdos-path)]) 94 | `(table (tr (i ,(format "~a" a1)) 95 | " co-authored with " 96 | (i ,(format "~a" a2)) 97 | ":") 98 | (tr (ul 99 | ,@(for/list ([p (papers a1 a2)]) 100 | `(li ,(format "~a" p)))))))) 101 | (tr "** " 102 | (i ,(format "~a" auth)) 103 | "'s " 104 | (b ,(format "~a" erdos)) 105 | "-number is: " 106 | (b ,(format "~a" erdos-num))) 107 | (tr (br) (hr)) 108 | (tr (br)) 109 | (tr 110 | ; ;; print bacon path 111 | ,@(for/list ([a1 bacon-path] 112 | [a2 (cdr bacon-path)]) 113 | `(table (tr (i ,(format "~a" a1)) 114 | " co-authored with " 115 | (i ,(format "~a" a2)) 116 | ":") 117 | (tr (ul 118 | ,@(for/list ([p (papers a1 a2)]) 119 | `(li ,(format "~a" p)))))))) 120 | (tr "** " 121 | (i ,(format "~a" auth)) 122 | "'s " 123 | (b ,(format "~a" bacon)) 124 | "-number is: " 125 | (b ,(format "~a" bacon-num))) 126 | (tr (br) (hr)) 127 | (tr (br)) 128 | (tr 129 | "## " 130 | (i ,(format "~a" auth)) 131 | "'s " 132 | (b ,(format "~a-~a" erdos bacon)) 133 | "-number is: " 134 | (b ,(format "~a" (+ erdos-num bacon-num)))) 135 | (tr (br) (hr)))) 136 | 137 | ;;----------------------------------------------------------------------------- 138 | ;; web server front end 139 | 140 | (define author-choices 141 | (sort 142 | (filter-not 143 | (λ (v) (regexp-match #px"and\\s|b>|Felleisen\\." v)) 144 | (get-vertices PLT-GRAPH)) 145 | string* . author}) 154 | (div "\"Bacon\": " 155 | ,{(select-input 156 | author-choices 157 | #:selected? (lambda (x) (string=? x "Felleisen"))) 158 | . =>* . bacon}) 159 | (div "\"Erdos\": " 160 | ,{(select-input 161 | author-choices 162 | #:selected? (lambda (x) (string=? x "Flatt"))) 163 | . =>* . erdos}) 164 | (div ,{(submit "Compute!") . =>* . res})) 165 | ;(list author erdos bacon))) 166 | ;; Q: Why is author etc a list? 167 | (let ([response-gen 168 | (λ (embed/url) 169 | (response/xexpr 170 | `(html 171 | (title "Results") 172 | (body (h1 "Results") 173 | (div ,(plt-bacon-html (car author) (car bacon) (car erdos))) 174 | (br) (br) 175 | (a ([href ,(embed/url serve-bacon)]) "Start Again")))))]) 176 | (send/suspend/dispatch response-gen)))) 177 | 178 | ;(define (start request) (serve-bacon request)) 179 | 180 | (provide serve-bacon) 181 | (define (serve-bacon request) 182 | (define (response-generator embed/url) 183 | (response/xexpr 184 | `(html 185 | (head (title "PLT Bacon")) 186 | (body (h1 "PLT Bacon") 187 | (img ([src "plt-bacon.png"])) 188 | ,(embed-formlet embed/url author-formlet))))) 189 | (send/suspend/dispatch response-generator)) 190 | 191 | 192 | #;(serve/servlet start 193 | #:launch-browser? #t 194 | #:quit? #f 195 | #:listen-ip #f 196 | #:port 8000) 197 | -------------------------------------------------------------------------------- /spam.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Rudimentary spam detection 4 | 5 | (require racket/contract 6 | racket/port 7 | memoize 8 | net/http-client 9 | xml 10 | xml/path) 11 | 12 | (provide (contract-out [check-ip (-> string? any)])) 13 | 14 | (define blacklist-host "api.stopforumspam.org") 15 | 16 | ;; Returns #f if the lookup failed, if the response is malformed, or 17 | ;; if the IP doesn't appear. Return #t if the IP does appear. 18 | ;; 19 | ;; The result is memoized to avoid querying the server too often. 20 | (define/memo (check-ip ip) 21 | (define-values (status headers contents) 22 | (http-sendrecv blacklist-host 23 | (format "/api?ip=~a" ip))) 24 | (cond ;; only accept 200 OK 25 | [(regexp-match #"200 OK" status) 26 | (define response 27 | (string->xexpr (port->string contents))) 28 | (and response 29 | (equal? "yes" (se-path* '(response appears) response)))] 30 | [else #f])) 31 | --------------------------------------------------------------------------------