diff options
Diffstat (limited to 'org/cgi-bin/guest-book.cgi')
| -rwxr-xr-x | org/cgi-bin/guest-book.cgi | 218 |
1 files changed, 218 insertions, 0 deletions
diff --git a/org/cgi-bin/guest-book.cgi b/org/cgi-bin/guest-book.cgi new file mode 100755 index 0000000..84fc7f0 --- /dev/null +++ b/org/cgi-bin/guest-book.cgi @@ -0,0 +1,218 @@ +#! /usr/local/bin/guile3 \ +-e main -s +!# + +(use-modules (ice-9 exceptions)) +(use-modules (srfi srfi-19)) +(use-modules (sxml simple)) +(use-modules (json)) + +(define guest-book-json-file "guest-book.json") + +(define (decode-hex hex) + (string (integer->char + (string->number (string-append "#x" + hex))))) + +;; Handle query string encoding +(define (format-query-string item) + (letrec ((decode-query + (lambda (value) + (let ((index (string-index value #\%)) + (value-length (string-length value))) + (cond ((and index value-length) + (string-append (substring value 0 index) + (decode-hex (substring value + (+ index 1) + (+ index 3))) + (cond ((< index (- value-length 3)) + (decode-query + (substring value + (+ index 3) + value-length))) + (else "")))) + (else value)))))) + (decode-query (string-map (lambda (character) + (case character + ((#\+) #\space) + (else character))) + item)))) + +;; Progress form data +(define (get-form) + (let ((query (getenv "QUERY_STRING"))) + (cond ((string= query "") #f) + (else + (map (lambda (item) + (let ((pairs (string-split item #\=))) + (set-cdr! pairs (format-query-string (cadr pairs))) + pairs)) + (string-split query #\&)))))) + +(define (sanitize-input value) + (let ((output (open-output-string)) + (sanitized "")) + (sxml->xml `(*TOP* ,value) output) + (set! sanitized (get-output-string output)) + (close-output-port output) + sanitized)) + +(define (write-guest-to-json name url message) + (let ((guest-book '()) + (guest `(("name" . ,name) + ("url" . ,url) + ("message" . ,message) + ("date" . ,(date->string (current-date) "~B, ~d ~Y")))) + (not-already-added #t)) + + (if (file-exists? guest-book-json-file) + (call-with-input-file guest-book-json-file + (lambda (fp) + (set! guest-book (vector->list (json->scm fp))) + ;; Handle order thingy + (set! guest-book (map (lambda (item) + (reverse item)) + guest-book))))) + + ;; Guest already added. + (letrec ((check-if-already-added + (lambda (guests) + (unless (eq? guests '()) + (cond ((compare-guests 0 (car guests) guest) + (set! not-already-added #f)) + (else + (check-if-already-added (cdr guests))))))) + (compare-guests + (lambda (index guest1 guest2) + (and (string= (cdr (list-ref guest1 index)) + (cdr (list-ref guest2 index))) + (cond ((< index 3) + (compare-guests (+ index 1) guest1 guest2)) + (else #t)))))) + (check-if-already-added guest-book)) + + ;; Add guest to guest-book + (cond (not-already-added + (cond ((eq? guest-book '()) + (set! guest-book (list guest))) + (else + (append! guest-book (list guest)))) + + ;; Write guest book to json + (call-with-output-file guest-book-json-file + (lambda (fp) + (scm->json (list->vector guest-book) fp))) + + (display "<p>You been added to the guest book yippe (:</p>\ +<img src=\"../images/yippee.gif\" alt=\"yippee!\"/>\n")) + (else + (display "You already been added\n"))))) + +(define (handle-fields) + (let ((form (get-form))) + (if form + (let ((name (sanitize-input (cdr (list-ref form 0)))) + (url (sanitize-input (cdr (list-ref form 1)))) + (message (sanitize-input (cdr (list-ref form 2))))) + (cond ((string= name "") ;; No name given + (display "<p>name is required</p>")) + ((string= message "") ;; No message given + (display "<p>please write a silly something (:</p>")) + (else + (write-guest-to-json name url message))))))) + +;; Display a guest in the guest book +(define (display-guest guest) + (let ((date (cdr (list-ref guest 0))) + (message (cdr (list-ref guest 1))) + (url (cdr (list-ref guest 2))) + (name (cdr (list-ref guest 3)))) + (format #t " <table border=\"1\" width=\"60%\">\n\ + <tr><td>\n\ + <b>~a</b> <a href=\"~a\" target=\"_blank\">~a</a> --- signed ~a\n\ + </td></tr>\n\ + <tr><td>\n\ + <p>~a</p>\n\ + </table>\n\n" name url url date message))) + +;; Display pretty much everything +(define (display-guest-book) + (display "Content-Type: text/html\n\n\ +<!DOCTYPE html>\n\ +<html>\n\ +<head>\n\ + <title>Guest Book</title>\n\ + <style>\n\ +body {\n\ + color: black;\n\ + background-image: url('../images/guest_book_background.png');\n\ +}\n\ +\n\ +table {\n\ + color: black;\n\ + background-color: #bebebe;\n\ + margin-top: 10px;\n\ + margin-bottom: 10px;\n\ + margin-left: 10px;\n\ + margin-right: 10px;\n\ +}\n\ +</style>\n\ +</head>\n\ +<body>\n\ + <a href=\"../index.html\"><img src=\"../images/back_home.png\"\n\ + alt=\"Back to home page\"/></a>\n\ + <center>\n\ + <table border=\"1\" width=\"60%\">\n\ + <tr>\n\ + <td>\n\ + <h3>Sign my fucking guest book</h3>\n\ + <form action = \"guest_book.cgi\" method = \"get\">\n\ + <lable for = \"name\" maxlength=\"100\">Name</lable>\n\ + <input type = \"text\" name = \"name\"/>\n\ + <br/>\n\ + <lable for = \"url\" maxlength=\"256\">Website (Optional)\n\ + </lable>\n\ + <input type = \"text\" name = \"url\"/>\n\ + <br/><br/>\n\ + <lable for = \"message\">Write a little silly something</lable>\n\ + <br/>\n\ + <textarea type = \"text\" name = \"message\" rows = \"4\"\n\ + cols = \"40\" maxlength=\"512\"></textarea>\n\ + <br/>\n\ + <input type = \"submit\" value = \"Fucking submit\">\n\ + <b>You can't delete/edit it afterwards</b>\n\ + </form>\n\ + <p>\n\ + <b>Be nice! Dont be a fucking ass.</b>\n\ + </p>\n") + (handle-fields) + (display " </td>\n\ + </tr>\n\ + </table>\n\n") + + ;; Try to read the guest book json + (with-exception-handler + (lambda (error) + (display " <table border=\"1\" width=\"60%\">\n\ + <tr><td>\n\ + <p>No guest(s) have been added ): But you can be the first!</p>\n\ + </td></tr>\n\ + </table>\n")) + (lambda () + (call-with-input-file guest-book-json-file + (lambda (fp) + (letrec ((guest-book (json->scm fp)) + (guest-loop + (lambda (index) + (display-guest (vector-ref guest-book index)) + (if (> index 0) + (guest-loop (- index 1)))))) + (guest-loop (- (vector-length guest-book) 1)))))) + #:unwind? #t) + + (display " </center>\n\ +</body>\n\ +</html>\n")) + +(define (main args) + (display-guest-book)) |