httpserver.scm
| 1 | (define-module (pastebin httpserver)) |
| 2 | |
| 3 | (use-modules (web request) |
| 4 | (web response) |
| 5 | (sxml simple) |
| 6 | (pastebin data) |
| 7 | (rnrs bytevectors) |
| 8 | (ice-9 textual-ports) |
| 9 | (ice-9 regex) |
| 10 | (srfi srfi-1)) |
| 11 | |
| 12 | (export make-pastebin-handler) |
| 13 | |
| 14 | (define (read-parts reqbody boundary) |
| 15 | (define b2 (string-append "(\r\n)?--" boundary)) |
| 16 | (let A ((start 0) (parts '())) |
| 17 | (let ((sm (string-match b2 reqbody start))) |
| 18 | (if sm |
| 19 | ;; +2 => CRLF |
| 20 | (A (+ 2 (match:end sm 0)) |
| 21 | (cons (substring reqbody start (match:start sm 0)) parts)) |
| 22 | (cdr (reverse parts)))))) |
| 23 | |
| 24 | (define (get-new-pin str pin) |
| 25 | (let ((crlfi (string-contains str "\r\n" pin))) |
| 26 | (if crlfi crlfi (string-length str)))) |
| 27 | |
| 28 | (define (parse-part partstr) |
| 29 | (let A ((headers '()) (pin 0)) |
| 30 | (let* ((newpin (get-new-pin partstr pin)) |
| 31 | (line (substring partstr pin newpin))) |
| 32 | (if (string-null? line) |
| 33 | (cons (reverse headers) (substring partstr (+ 2 newpin))) |
| 34 | (A (cons line headers) (+ 2 newpin)))))) |
| 35 | |
| 36 | (define (get-content-dispo-name-from-headers headers) |
| 37 | (let ((fl (find (lambda (line) (string-prefix-ci? "content-disposition: " line)) headers))) |
| 38 | (if fl |
| 39 | (let ((sm (string-match "name=(.*)" fl))) |
| 40 | (if sm (string-trim-both (match:substring sm 1) #\") "")) |
| 41 | ""))) |
| 42 | |
| 43 | (define (read-multipart-form-data reqbody boundary) |
| 44 | (define parts (read-parts reqbody boundary)) |
| 45 | (map |
| 46 | (lambda (part) |
| 47 | (let ((pp (parse-part part))) |
| 48 | (cons (get-content-dispo-name-from-headers (car pp)) (cdr pp)))) |
| 49 | parts)) |
| 50 | |
| 51 | (define (templatize title body) |
| 52 | `(html (head |
| 53 | (title ,title) |
| 54 | (meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))) |
| 55 | (body ,@body))) |
| 56 | |
| 57 | (define (make-pastebin-handler data-path) |
| 58 | (lambda (request request-body) |
| 59 | (if (eq? (request-method request) 'POST) |
| 60 | (let* ((headers (request-headers request)) |
| 61 | (content-type-all (assq-ref headers 'content-type)) |
| 62 | (content-type (if content-type-all (car content-type-all) #f)) |
| 63 | (boundary (if (eq? content-type 'multipart/form-data) |
| 64 | (assq-ref (cdr content-type-all) 'boundary) #f)) |
| 65 | (reqbody-string (utf8->string request-body))) |
| 66 | (if boundary |
| 67 | (let ((form-data (read-multipart-form-data reqbody-string boundary))) |
| 68 | (call-with-dir-as-pb-data |
| 69 | data-path |
| 70 | (lambda (pb-data) |
| 71 | (pb-data-new-entry pb-data |
| 72 | (assoc-ref form-data "text")))))))) |
| 73 | |
| 74 | (values (build-response |
| 75 | #:code 200 |
| 76 | #:headers `((content-type . (text/html)))) |
| 77 | |
| 78 | (lambda (port) |
| 79 | (let* ((top5 (call-with-dir-as-pb-data |
| 80 | data-path |
| 81 | (lambda (pb-data) (pb-data-get-top pb-data 5)))) |
| 82 | (sxml (templatize |
| 83 | "pastebin" |
| 84 | `((form (@ (method "post") (enctype "multipart/form-data")) |
| 85 | (textarea (@ (name "text")) "") (input (@ (type "submit")))) |
| 86 | (table (@ (border 1)) (tr (th "id") (th "text")) |
| 87 | ,(map (lambda (entry) `(tr (td ,(pb-entry-id entry)) |
| 88 | (td ,(pb-entry-text entry)))) |
| 89 | top5)))))) |
| 90 | (display "<!DOCTYPE html>\n" port) |
| 91 | (sxml->xml sxml port)))))) |
| 92 |