#! /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 " <hr />\n <div class=\"container\">
<b>~a</b> <a href=\"~a\" target=\"_blank\">~a</a> --- signed ~a\n\
<div class=\"silly-something\"><p>~a</p></div>\n\
</div>\n <br />\n" name url url date message)))
;; Display pretty much everything
(define (display-guest-book)
(display "Content-Type: text/html\n\n\
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n\
\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n\
<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en\" xml:lang=\"en\">\n\
<head>\n\
<title>Guest Book</title>\n\
<link rel=\"icon\" type=\"image/x-icon\" href=\"../images/icon.png\" />
<link rel=\"stylesheet\" type=\"text/css\" href=\"../css/guest-book.css\" />\n\
</head>\n\
<body>\n\
<a href=\"../index.xhtml\"><img src=\"../images/back_home.png\"\n\
alt=\"Back to home page\"/></a>\n\
<div class=\"container\">\n\
<h2>Sign my fucking guest book</h2>\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 " </div>\n <br />\n")
;; Try to read the guest book json
(with-exception-handler
(lambda (error)
(display " <div class=\"container\">\n\
<p>No guest(s) have been added ): But you can be the first!</p>\n\
</div>\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 "</body>\n</html>\n"))
(define (main args)
(display-guest-book))