| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233 |
- (add-to-load-path (dirname (current-filename)))
- (use-modules
- (ice-9 textual-ports)
- (ice-9 regex)
- (decode)
- (email)
- (web server)
- (web request)
- (web response)
- (web uri)
- (oop goops)
- (sxml simple)
- ;; (srfi srfi-19)
- )
- (define* (templatize title body
- #:key
- (js-files #f))
- `(html (head (title ,title)
- (head
- (link (@ (type "text/css") (href "css/form.min.css") (rel "stylesheet")) "")
- ,(if js-files
- `(script (@ (async) (src ,(string-append "js/" js-files))) " ")
- `(link (@ (type "text/css") (href "#")) ""))
- )
- (body ,@body))
- ))
- (define* (respond #:optional body #:key
- (status 200)
- (title "form")
- (doctype "<!DOCTYPE html>\n")
- (content-type-params '((charset . "utf-8")))
- (content-type 'text/html)
- (extra-headers '())
- (js-files #f)
- (sxml (and body (if js-files
- (templatize title body #:js-files js-files)
- (templatize title body)))))
- (values (build-response
- #:code status
- #:headers `((content-type
- . (,content-type ,@content-type-params))
- ,@extra-headers))
- (lambda (port)
- (if sxml
- (begin
- (if doctype (display doctype port))
- (sxml->xml sxml port))))))
- (define (request-path-components request)
- (split-and-decode-uri-path (uri-path (request-uri request))))
- ;; Paste this in your REPL
- (define (not-found request)
- (values (build-response #:code 404)
- (string-append "Resource not found: "
- (uri->string (request-uri request)))))
- (define (output-file file-name)
- (call-with-input-file file-name
- (lambda (port)
- (string-append
- ""
- (let loop ([string (get-line port)])
- (if (eof-object? string)
- ""
- (string-append
- string "\n" (loop (get-line port)))))))))
- (define (submit-page bv)
- (respond
- `((div (@ (class "container"))
- (div (@ (class "row"))
- (div (@ (class "col-md-12"))
- ,(let* ([alist (decode bv)]
- ;;(if (and (not null? (assoc-ref alist "timestamp"))))
- ;; [form-timestamp-pair
- ;; (string-split (car (assoc-ref alist "timestamp")) #\space)]
- ;; [form-timestamp-seconds (car form-timestamp-pair)]
- ;; [form-timestamp-microseconds (car (cdr form-timestamp-pair))]
- ;; [timestamp (gettimeofday)]
- ;; [timestamp-seconds (car timestamp)]
- ;; [timestamp-microseconds (cdr timestamp)]
- ;; [form-completion-time-seconds
- ;; (- (current-time) (string->number form-timestamp-seconds))]
- ;; [form-completion-time-microseconds
- ;; (abs (- timestamp-microseconds
- ;; (string->number form-timestamp-microseconds)))]
- [name (car (assoc-ref alist "name"))]
- [phone (car (assoc-ref alist "phone"))]
- [domain (car (assoc-ref alist "domain"))]
- [email (car (assoc-ref alist "email"))]
- [message (car (assoc-ref alist "message"))]
- [honeypot (car (assoc-ref alist "address"))]
- [service1 (if (assoc-ref alist "service1")
- (car (assoc-ref alist "service1"))
- #f)]
- [service2 (if (assoc-ref alist "service2")
- (car (assoc-ref alist "service2"))
- #f)]
- [service3 (if (assoc-ref alist "service3")
- (car (assoc-ref alist "service3"))
- #f)]
- [service4 (if (assoc-ref alist "service4")
- (car (assoc-ref alist "service4"))
- #f)]
- [service5 (if (assoc-ref alist "service5")
- (car (assoc-ref alist "service5"))
- #f)]
- [service6 (if (assoc-ref alist "service6")
- (car (assoc-ref alist "service6"))
- #f)]
- [service7 (if (assoc-ref alist "service7")
- (car (assoc-ref alist "service7"))
- #f)]
- [service8 (if (assoc-ref alist "service8")
- (car (assoc-ref alist "service8"))
- #f)]
- ;;[service9 (car (assoc-ref alist "service9"))]
- [service9 (if (assoc-ref alist "service9")
- (car (assoc-ref alist "service9"))
- #f)]
- )
- ;; if this form was completed in under 200000 microseconds, then this may be a computer trying to log in
- ;; don't let them log in. OR if the honeypot had any value in it...
- ;; (if (or (and (= 0 form-completion-time-seconds)
- ;; (> 200000 form-completion-time-microseconds))
- ;; (not (string= honeypot "")))
- ;; '(p "We're having issues...please try again later."))
- ;; ,(string-append
- ;; "It took you "
- ;; ;;(number->string form-completion-time-seconds)
- ;; " seconds and "
- ;; ;;(number->string form-completion-time-microseconds)
- ;; " microseconds to complete the form.\n")
- (if (string= honeypot "")
- (begin
- (send-email email "Hosting at GNUcode.me"
- (string-append
- "You have decided to use
- some of the services provided by gnucode.me! Josh will contact you
- will the payment details, and we'll have your services set up in no time."))
- (send-email "jbranso+services@dismail.de"
- (string-append "GNUcode.me Supporter:" name)
- (string-append name " wants to host their site :"
- domain
- " with you! Their number is "
- phone
- ".\nTheir email is "
- email
- ".\n"
- "Their message is:\n"
- message
- "Their services are:"
- service1 "\n"
- service2 "\n"
- service3 "\n"
- service4 "\n"
- service5 "\n"
- service6 "\n"
- service7 "\n"
- service8 "\n"
- service9 "\n"
- ))
- `(p "Awesome! You'll be getting an email
- from me soon! I'm glad that you are looking forward to supporting me!"))
- `(p "You must be a robot.")))
- ))))))
- (define (main-page)
- (respond
- `((form (@ (action "submit.scm") (method "post"))
- (div
- (label (@ (for "name")) "Name")
- (input (@ (id "name") (type "text") (name "name") (placeholder "Greg Jones"))))
- (div
- (label (@ (for "email")) "Email")
- (input (@ (id "email") (type "email") (name "email") (placeholder "email@example.com"))))
- (div
- ;; this is a honeypot. It's an hidden input, that users will leave empty, but computer programs
- ;; will put in a value.
- (label (@ (for "address") (class "hidden")) "address")
- (input (@ (id "address") (type "text") (class "hidden") (name "address"))))
- (div
- (label (@ (for "timestamp") (class "hidden")) "timestamp")
- (input (@ (id "timestamp") (type "number") (class "hidden") (name "timestamp")
- (value ,(string-append
- (number->string (car (gettimeofday)))
- " "
- (number->string (cdr (gettimeofday))))
- ))))
- (div
- (label (@ (id "phone") (for "phone")) "Phone")
- (input (@ (type "tel") (name "phone") (placeholder "224-930-0493"))))
- (div
- (label (@ (id "subject") (for "subject")) "Subject")
- (input (@ (type "text") (name "subject") (placeholder "Website Hosting"))))
- (div
- (label (@ (id "domain") (for "domain")) "Domain")
- (input (@ (type "text") (name "domain") (placeholder "gregsblog.com"))))
- (div
- (label (@ (id "message") (for "message")) "Message")
- (textarea (@ (name "message") (cols "26") (rows "6")
- (placeholder "Will you host my website?"))
- ;;necessary to properly close <textarea></textarea> tag.
- ()))
- (div
- (button (@ (type "submit")) "Submit"))))))
- (define (run-page request body)
- ;;(display (request-path-components request))
- (let ([current-page (request-path-components request)])
- (cond
- [(equal? current-page '("form" "css" "form.min.css"))
- (values `((content-type . (text/css)))
- (output-file "css/form.min.css"))]
- [(equal? current-page '("form" "index.scm"))
- (main-page)]
- [(equal? current-page '("form" "submit.scm"))
- (submit-page body)]
- [else
- (respond `((h1 "Page not found.")
- (h1 ,(let loop ([current-page current-page])
- (if (null? current-page) ""
- (string-append (car current-page) "/"
- (loop (cdr current-page))))))
- (h2 ,current-page)))])))
- (run-server run-page 'http '(#:port 8081))
|
