Almost done with this stupidness

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))