| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129 |
- (use-modules (web server)
- (web request)
- (web response)
- (web uri)
- (sxml simple)
- (ice-9 regex))
- ;; this is probably not necessary. I'd just have nginx serve these files
- (define css-pattern (make-regexp ".*css$" regexp/extended))
- (define js-pattern (make-regexp ".*js$" regexp/extended))
- (define sxml-pattern (make-regexp ".*sxml$" regexp/extended))
- (define (not-found request)
- (values (build-response #:code 404)
- (string-append "Resource not found: "
- (uri->string (request-uri request))
- " length is "
- (number->string (string-length
- (uri->string
- (request-uri request)))))))
- (define* (templatize title body #:optional style)
- `(html (head (title ,title)
- ,(when style
- '(link (@ (rel "stylesheet") (href "style.css")
- (type "text/css")))))
- (body ,@body)))
- (define* (respond #:optional body #:key
- (style #f)
- (status 200)
- (title "Upselling")
- (doctype "<!DOCTYPE html>\n")
- (content-type-params '((charset . "utf-8")))
- (content-type 'text/html)
- (extra-headers '())
- (sxml (and body (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))))
- (define (serve-page request body)
- (cond
- [(equal? (request-path-components request) '("hacker"))
- (respond
- #:sxml
- '((h1 "Upselling")
- (body
- (p "Hey there!"))
- (table
- (tr (th "header") (th "value"))
- ,@(map (lambda (pair)
- `(tr (td (tt ,(with-output-to-string
- (lambda () (display (car pair))))))
- (td (tt ,(with-output-to-string
- (lambda ()
- (write (cdr pair))))))))
- (request-headers request)))
- ))]
- [(equal? (request-path-components request) '("submit.scm"))
- (respond
- '((body (h1 "hello")))
- )
- ]
- ((equal? (request-path-components request) '("about"))
- (respond
- '((body
- (p "About")))))
- ((equal? (request-path-components request) '("contact"))
- (respond
- '((h1 "contact")
- (body
- (p "contact")))))
- ((equal? (string-length (uri->string (request-uri request))) 1)
- (respond
- #:style "style.css"
- #:sxml
- '((body
- (main (@ (class body))
- (div (@ (class "content"))
- (h1 "Upselling")
- (form (@ (action "/submit.scm")
- (method "post"))
- (ul
- (li
- (label (@ (for "confirmation"))
- "Confirmation #:")
- (input (@ (type "text") (id "confirmation") (name "confirmation"))))
- (li
- (label (@ (for "los"))
- "Length of Stay:")
- (input (@ (type "text") (id "los") (name "los")))
- (input (@ (type "submit") (id "los") (name "los")))))))
- )))
- ))
- ;;The next three are probably not necessary.
- ;;I'll probably just have nginx serve these kinds of files
- ((regexp-exec css-pattern (uri->string (request-uri request)))
- (values (build-response)
- "style.css file content goes here."))
- ((regexp-exec js-pattern (uri->string (request-uri request)))
- (values (build-response)
- "javascript.js file content goes here."))
- ((regexp-exec sxml-pattern (uri->string (request-uri request)))
- (values (build-response)
- "sxml->xml is run on file content."))
- (else (not-found request))))
- (run-server serve-page)
- ;; building URIs
- ;; (uri->string
- ;; (build-uri 'http #:host "www.gnu.org"
- ;; #:port 55
- ;; #:path "/documentation/emacs/index.scm"
- ;; #:query "hello=5"
- ;; #:fragment "cool-spot"
- ;; ))
|
