ZelphirKaltstahl
/
guile-examples


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147
							;; Instead of using Guile's built in web server, we simply use fibers
;; web server. The interface for the developer seems to be the
;; same. Handlers will now handle requests in spawned fibers, instead
;; of one at a time blocking each other.
(use-modules (fibers web server))

;; (use-modules (web server))  ; Not using Guile's built in web server.

(use-modules (web request)
             (web response)
             (web uri))
(use-modules (sxml simple))
(use-modules (ice-9 hash-table))  ; alist->hash-table


;; =========================
;; REQUEST/RESPONSE HANDLING
;; =========================
(define* (respond #:optional body #:key
                  (status 200)
                  (title "This is my title!")
                  (doctype "<!DOCTYPE html>\n")
                  (content-type-params '((charset . "utf-8")))
                  (content-type 'text/html)
                  (extra-headers '())
                  ;; if a body is provided use its templatized form
                  (sxml (and body (templatize title body))))
  ;; as before, answer in two parts, headers and body
  (values (build-response #:code status
                          ;; headers are an alist
                          #:headers `((content-type . (,content-type ,@content-type-params))
                                      ,@extra-headers))
          ;; instead of returning the body as a string, respond gives
          ;; a procedure, which will be called by the web server to
          ;; write out the response to the client.
          ;; So you have 2 options: return string or return procedure which takes a port.
          (λ (port)
            (if sxml
                (begin
                  (if doctype (display doctype port))
                  (sxml->xml sxml port))))))


(define (request-path-components request)
  ;; just for showing what the functions do
  ;; (display (simple-format #f "(request-uri request): ~a\n"
  ;;                         (request-uri request)))
  ;; (display (simple-format #f "(uri-path ...): ~a\n"
  ;;                         (uri-path (request-uri request))))
  ;; (display (simple-format #f "(split-and-decode-uri-path ...): ~a\n"
  ;;                         (split-and-decode-uri-path (uri-path (request-uri request)))))
  ;; actual logic
  ;; split the string that represents the uri and decode any url-endoced things
  (split-and-decode-uri-path
   ;; get the uri path as a string from the request struct
   (uri-path
    ;; get the request struct
    (request-uri request))))


(define (debug-handler request body)
  ;; use respond helper
  (respond
   ;; will be templatized
   `((h1 "hello world!")
     (table
      (tr (th "header") (th "value"))
      ;; splice in all request headers
      ,@(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))))))


(define (hello-world-handler request request-body)
  "A handler for a route."
  ;; A handler must return 2 values: The header and body of the
  ;; response.
  (values
   ;; headers first (the bare minimum)
   '((content-type . (text/plain)))
   ;; then the response body
   "Hello World!"))


(define (blocking-wait-handler request request-body)
  "A handler for a route which waits blockingly for testing concurrent
connections."
  (sleep 10)
  (values
   ;; headers first (the bare minimum)
   '((content-type . (text/plain)))
   ;; then the response body
   "I've been waiting for you ..."))


;; =========
;; TEMPLATES
;; =========
(define (templatize title body)
  `(html (head (title ,title))
         (body ,@body)))


;; ======
;; SERVER
;; ======
;; A hash that contains routes to handler associations
(define routes-config
  (alist->hash-table
   ;; using (quote ...) would not evaluate the handlers in the list
   ;; so we need quasiquote unquote
   `((("hello" "world") . ,hello-world-handler)
     (("debug") . ,debug-handler)
     (("wait") . ,blocking-wait-handler))))


(define (logging-middleware request body)
  "The logging middleware takes care of logging to stdout whenever a
request comes in. We can imagine all sorts of logging here."
  (display (simple-format #f "responding for request-path-components: ~s\n"
                          (request-path-components request))))


(define* (make-routes-dispatcher routes-config #:key (default-handler debug-handler))
  "return a procedure, which, for each request, looks up the
appropriate handler inside the given routes-config"
  (λ (request body)
    ;; Here we can have sequential actions. The first action in this
    ;; example is a logging middleware. We could make a middleware
    ;; return a result, which is then handed to the next middleware
    ;; which might in turn manipulate the result of the first one or
    ;; create a new result or whatever else we want to implement.
    (logging-middleware request body)
    ;; Only after logging the real request handling begins.  First we
    ;; get the appropriate handler and then we hand it the request.
    (let* ([route-parts (request-path-components request)]
           [handler (hash-ref routes-config route-parts default-handler)])
      ;; Hand the handler the request and the body of the request.
      (handler request body))))

;; Start the server.
(run-server (make-routes-dispatcher routes-config #:default-handler debug-handler))